FreeBASIC 1.07 Release Discussion

For other topics related to the FreeBASIC project or its community.
SARG
Posts: 909
Joined: May 27, 2005 7:15
Location: FRANCE

FreeBASIC 1.07 Release Discussion

Postby SARG » Aug 27, 2019 10:23

Discussion of FreeBASIC 1.07.x releases, issues, comments, remarks, etc. Full release announcement is posted at Version 1.07.0 released.

Original opening post follows. Sorry SARG, this is a good topic to commandeer for the discussion :) -- Jeff


----

Hi coderJeff,

Thanks for this new version.

The link to the change log on the released version 1.07 page --> "page not found"

By the way always working on gas64. For now lot of bugs fixed using the test suite :-) however the road is long :-(
coderJeff
Site Admin
Posts: 3118
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: FreeBASIC 1.07.0 Release Discussion

Postby coderJeff » Aug 27, 2019 21:25

oops, I forgot to push the '1.07.0' tag to sourceforge. changelog.txt link in the news post should work now.

link: changelog.txt

I took the liberty of changing your topic title.
VANYA
Posts: 1324
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: FreeBASIC 1.07.0 Release Discussion

Postby VANYA » Aug 28, 2019 2:41

Thanks for the new version!
Provoni
Posts: 342
Joined: Jan 05, 2014 12:33
Location: Belgium

Re: FreeBASIC 1.07.0 Release Discussion

Postby Provoni » Sep 01, 2019 17:30

Thanks coderJeff and all people involved for FreeBASIC 1.07!

Code: Select all

| | | |               | |                     
| |_| |__   __ _ _ __ | | ___   _  ___  _   _
| __| '_ \ / _` | '_ \| |/ / | | |/ _ \| | | |
| |_| | | | (_| | | | |   <| |_| | (_) | |_| |
 \__|_| |_|\__,_|_| |_|_|\_\\__, |\___/ \__,_|
                             __/ |           
                            |___/             
dodicat
Posts: 5984
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: FreeBASIC 1.07.0 Release Discussion

Postby dodicat » Sep 01, 2019 20:51

Code: Select all

 

Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Ulong,size As Single,textangle As Single=0,charangle As Single=0,im As Any Pointer=0)
    Type point2d
        As Single x,y
        As Ulong col
    End Type
    Dim As Integer flag,codenum=256
    if instr(text,"|") then flag=1
    Static As long runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(128,codenum)
    If runflag=0 Then                   
        Dim As Ulong background=0
        screen 8
        width 640\8,200\16 
        Dim count As long
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As long=1 To 8 
                For y As long=1 To 16
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)
                    End If
                Next y
            Next x
            count=0
        Next ch
        runflag=1
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 128,codenum),np
    Dim As Single cr= 0.01745329 'degs to radians
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
   
    Dim As point2d cpt(1 To 128),c=Type<point2d>(xpos,ypos),c2
    Dim As Integer dx=xpos,dy=ypos
    For z6 As Integer=1 To Len(text)
        var asci=text[z6-1]
        If asci=124 Then
            if charangle<>0 then xpos=xpos+12*sin(charangle*cr)
            dx=xpos:dy=dy+16:Goto skip 'pipe | for new line
        End If
        For _x1 As Integer=1 To 128
            temp(_x1,asci).x=infoarray(_x1,asci).x+dx
            temp(_x1,asci).y=infoarray(_x1,asci).y+dy
            temp(_x1,asci).col=colour
            rotate(c,temp(_x1,asci),textangle,size)
            cpt(_x1)=np
            var copyy=np.y
            If charangle<>0 Then
                dim as long p
              if flag then  p=1 else  p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr)))
                rotate(c2,cpt(_x1),charangle,1)
               if flag then np.y=copyy
                cpt(_x1)=np
            End If
            If infoarray(_x1,asci).x<>0 Then
                If Abs(size)>1 Then
                    line(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
                Else
                    Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
                End If
            End If
        Next _x1
        dx=dx+9+4*(sin(charangle*cr))*flag
        skip:
    Next z6
End Sub
Sub init Constructor
    drawstring(0,0,"",0,0)
    Screen 0
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
        Static As Double timervalue,_lastsleeptime,t3,frames
        frames+=1
        If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
        Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
        If sleeptime<1 Then sleeptime=1
        _lastsleeptime=sleeptime
        timervalue=Timer
        Return sleeptime
    End Function

screenres 850,550,32
color ,rgb(0,0,50)

dim as double sx=32,sy=0,stx=100,sty=50,svx,hvx,ivx,fvx,tvx,svy,hvy,ivy,fvy,tvy
 for a as double=0 to 360 step .5
    svx=3.333333333333334*a-9.259259259259261e-003*a*a
    svy=-0.1114551083591331*a+3.095975232198143e-004*a*a
    hvx=-1.168831168831169*a+3.246753246753247e-003*a*a
    hvy=-1.111111111111111*a+3.08641975308642e-003*a*a
    ivx=4.800000000000001*a-1.333333333333334e-002*a*a
    ivy=2.408026755852843*a-6.688963210702342e-003*a*a
    fvx=0.2*a -5.555555555555557e-004*a*a
    fvy=-0.5555555555555556*a+1.54320987654321e-003*a*a
    tvx= -3.636363636363638*a+1.010101010101011e-002*a*a
    tvy= (-5.14285714285715*a+1.42857142857143e-002*a*a)/10
     screenlock
     cls
 drawstring(stx+a+svx,sty+sy+a+svy,"H",rgb(255,0,0),3,0,2*a)
 drawstring(stx+sx+a+hvx,sty+sy+a+hvy,"A",rgb(0,254,0),3,0,8*a)
 drawstring(stx+2*sx+a+ivx,sty+sy+a+ivy,"N",rgb(255,254,255),3,0,30*a)
 drawstring(stx+3*sx+a+fvx,sty+sy+a+fvy,"K",rgb(0,0,255),3,0,-6*a)
 drawstring(stx+4*sx+a+tvx,sty+sy+a+tvy,"S",rgb(255,200,0),3,0,-20*a)
 screenunlock
 sleep regulate(60),1
next a
 drawstring(420,405,"T",rgb(200,200,100),5)   

 sleep 
coderJeff
Site Admin
Posts: 3118
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: FreeBASIC 1.07.0 Release Discussion

Postby coderJeff » Sep 02, 2019 11:52

You are very welcome guys. fbc 1.07.0 was pushed out a little earlier than I had planned, however, I still tested as thoroughly as possible before uploading the release packages.

If you notice any reports in the forum that seem related to this release (or an earlier release), please feel free to post or link here, thanks.

Binary compatibility changed:
- for best compatibility, any libraries (dynamic or static), must be recompiled with the current version used
- FYI, in fbc 1.08 we will break binary compatibility again.

DOS DLL support: viewtopic.php?f=17&p=263929#p263929

Building on msys2: viewtopic.php?p=263702#p263702

----
@dodicat, I see your regulate() function in many of your listings and seems to work well. Like it should be built in to an extension SCREENSYNC somehow as a gfxlib feature for software based timing.
deltarho[1859]
Posts: 2083
Joined: Jan 02, 2017 0:34
Location: UK

Re: FreeBASIC 1.07.0 Release Discussion

Postby deltarho[1859] » Sep 02, 2019 15:31

Slightly off topic but dodicat's code works with gcc 7.4 64-bit (-02)

5.2 128000 bytes
7.4 124416 bytes

That is only 3.5KB smaller but is better than a poke in the eye with a sharp stick. <laugh>
aloberoger
Posts: 480
Joined: Jan 13, 2009 19:23

Re: FreeBASIC 1.07.0 Release Discussion

Postby aloberoger » Sep 03, 2019 8:43

Coderjeff Wrote:
If you notice any reports in the forum that seem related to this release (or an earlier release), please feel free to post or link here, thanks.
Binary compatibility changed:
- for best compatibility, any libraries (dynamic or static), must be recompiled with the current version used
- FYI, in fbc 1.08 we will break binary compatibility again.



OK

Indeed you have been clear.
in my tests I found that some old dll run successfully see http://s000.tinyupload.com/?file_id=56545952651317791492
can we have a theory for the type of dll that can be executed successfully
here is the source code:

Code: Select all

#Include Once "win/ocidl.bi"
#Include Once "crt.bi"

 
#Ifndef __COMVARIANT_INC__
#Define __COMVARIANT_INC__


   'NOTE: VARIANT_BOLL must be contruct normally like variant  example: dim v as Comobject:v.vt=VT_BOOL: v.boolval=-1



#Ifndef __WIDESTRING_INC__

Function BstrWriteToStream(m_bstr As BSTR,pStream As IStream Ptr ) As HRESULT
      Assert(pStream <> NULL)
      Dim As ULong cb
      Dim As ULong cbStrLen =IIf( m_bstr , SysStringByteLen(m_bstr)+sizeof(OLECHAR) , 0)
      #Ifdef __FB_COM_NO_VTBL__
        Dim As HRESULT hr = pStream->Write(cast(void ptr, @cbStrLen), sizeof(cbStrLen), @cb)
      #Else
        Dim As HRESULT hr = pStream->lpvtbl->Write(pStream,Cast(void ptr, @cbStrLen), sizeof(cbStrLen), @cb)
      #EndIf
      if (FAILED(hr)) Then
         return hr
      EndIf   
      If cbStrLen Then
         #Ifdef __FB_COM_NO_VTBL__
            Return   pStream->Write(cast(void ptr, m_bstr), cbStrLen, @cb)
         #Else
             Return  pStream->lpvtbl->Write(pStream,Cast(void ptr, m_bstr), cbStrLen, @cb)
         #EndIf
      Else
         Return S_OK
      EndIf

End Function

#EndIf


Extern "windows" Lib "atl"
      Declare Function AtlAxAttachControl(As IUnknown Ptr,As HWND,As IUnknown Ptr Ptr) As HRESULT  ' Attaches a previously created control to the specified window.
End Extern



' Comobject

Type Comobject extends VARIANTARG

Private:
     Declare Function  InternalClear() As HRESULT
   Declare Sub InternalCopy(ByVal pSrc as VARIANT Ptr )
   'private functions
Declare Function CountArgsInFormat(pszFmt As String) As UINT 
Declare Function GetVarType(psmzFmt As  String ,pvt as VARTYPE Ptr ) As  String
Declare FUNCTION PARSE  (source as string, delimiter as String="|", index as integer)as String
Declare Function PARSECOUNT( source As String, delimiter As String=",")As Long

Declare Sub OleErrorShow ( hr As HRESULT, addit As String="")

public:
   Declare Constructor ()
   Declare Destructor ()
   Declare Constructor (ByRef varSrc As Const VARIANT  )
   Declare Constructor (ByRef varSrc As VARIANT  )
   Declare Constructor (ByRef varSrc As  Comobject)
   Declare Constructor (byval bstrSrc AS BSTR)
   Declare Constructor (byval value as String )
   Declare Constructor (byval lpszSrc AS LPCOLESTR)
   'Declare Constructor (byval bSrc as BOOLEAN)
    Declare Constructor (byval nSrc AS Integer)
   Declare Constructor (byval nSrc AS Byte)
   Declare Constructor (byval nSrc AS Short)
   Declare Constructor (byval nSrc AS Long,vtSrc As  VARTYPE  = VT_I4)
   Declare Constructor (byval fltSrc AS float)
   Declare Constructor (byval dblSrc AS Double)
   Declare Constructor (byval cySrc AS CY)
   Declare Constructor (byval pSrc AS IDispatch Ptr,fAddRef As bool  = CTRUE)
   Declare Constructor (byval pSrc AS IUnknown Ptr,fAddRef As bool  = CTRUE)
   Declare Constructor (byval  as SAFEARRAY Ptr)
   Declare Constructor (ByRef decSrc As Const DECIMAL )   
     
   Declare operator Let(ByRef lvarSrc AS Comobject)
   Declare operator Let(ByVal varSrc as VARIANT)
   Declare operator Let(byval bstrSrc AS BSTR)
   Declare operator Let(byval bstrSrc AS String)
   Declare operator Let(byval lpszSrc AS LPCOLESTR)
  ' Declare  operator Let(byval bSrc as BOOLEAN)
   Declare  Operator Let(byval nSrc AS Integer)
   Declare  operator Let(byval nSrc AS BYTE)
   Declare  operator Let(byval nSrc AS Short)
   Declare  Operator  Let(byval nSrc AS Long)
   Declare  operator Let(byval fltSrc AS float)
   Declare  operator Let(byval dblSrc AS double)
   Declare  operator Let(byval cySrc AS CY)
   Declare  operator Let(byval pSrc AS IDispatch ptr)
   Declare  operator Let(byval pSrc AS IUnknown ptr)
   Declare  Operator Let(byval  as SAFEARRAY Ptr)
   Declare Operator Let(ByRef decSrc As Const DECIMAL )
   
   
   'Declare operator Let(ByVal varSrc as VARIANT)
   
   
   Declare Function  Clear() As HRESULT
   Declare Function  Copy(pSrc As  VARIANT ptr ) As HRESULT
   Declare Function  Attach(pSrc As  VARIANT ptr) As HRESULT   
   Declare Function  Detach(pDest As VARIANT Ptr )As HRESULT
   Declare Function  Detach() As VARIANT Ptr 
   Declare Function  ChangeType(vtNew As VARTYPE ,ByVal pSrc As  VARIANT ptr = NULL) As HRESULT

   Declare Function WriteToStream(pStream As IStream Ptr) As HRESULT
   Declare Function ReadFromStream(pStream As IStream Ptr ) As  HRESULT


    Declare Operator cast() as Integer
    Declare Operator cast() As Byte
    Declare Operator cast() AS Short
    Declare operator cast() AS Long
    Declare operator cast() AS float
    Declare operator cast() AS Double
    Declare operator cast() AS CY
    Declare Operator Cast() AS DECIMAL
     Declare Operator cast() as String
     Declare Operator cast() as BSTR
    Declare operator cast() AS IDispatch Ptr
    Declare operator cast() AS IUnknown Ptr
    Declare Operator Cast() as SAFEARRAY Ptr
 
      
    Declare Operator += ( byval rhs as string )
   
   
    Declare Sub CreateObject (ByVal ProgID as LPCOLESTR)
    Declare Sub CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR)
    Declare Function CreateObject (szProgId As LPCOLESTR ,riid As REFIID ,dwClsContext As DWORD , _
                        mpServerInfo As COSERVERINFO ptr ,ppv as lpvoid Ptr ) As HRESULT
    Declare Function GetObjectEx(szPathName As LPCOLESTR ,szProgId As LPCOLESTR ,riid As REFIID , _
                      dwClsContext As DWORD ,lpvReserved As LPVOID , ppv As LPVOID Ptr) As HRESULT
    Declare sub  GetObject (szPathName As LPCOLESTR =NULL,szProgId As LPCOLESTR) 
    Declare Sub  GetObject(strName As LPCOLESTR)
    Declare Function getEnumVariant() As IEnumVARIANT Ptr
    Declare Sub AttachControl(hwnd As HWND)           ' if .ocx attach a prébuild control Handle
    Declare Function Invoke  Cdecl  (wFlags As WORD ,szName As LPCOLESTR , pszFmt as String="" ,argList As Any Ptr)As Comobject
    Declare Function Method Cdecl(MethodName As LPCOLESTR , pszFmt as String="" ,...)As Comobject
    Declare Function PropGet Cdecl (PropName As LPCOLESTR , pszFmt as String="" , ...)As Comobject
    Declare Sub  PropPut  Cdecl (szName As LPCOLESTR,pszFmt as String,...)   
    Declare Sub  PropPutRef  Cdecl (szName As LPCOLESTR,pszFmt as String,...)
End Type




   Constructor Comobject()   Export
      vt = VT_EMPTY
   End Constructor
   
   Destructor Comobject()  Export
      Clear()
   End Destructor

   Constructor Comobject(ByRef varSrc As Const VARIANT  )  Export
      vt = VT_EMPTY
      InternalCopy(Cast(VARIANT Ptr,@varSrc))
   End Constructor
   
   Constructor Comobject(ByRef varSrc As VARIANT  )  Export
      vt = VT_EMPTY
      InternalCopy(@varSrc)
   End Constructor
   
   Constructor Comobject(ByRef varSrc As  Comobject  )  Export
      vt = VT_EMPTY
      InternalCopy(@varSrc)
   End Constructor

   Constructor Comobject(byval bstrSrc AS BSTR)  Export
      vt = VT_BSTR
      bstrval = bstrSrc
   End Constructor
   
 
   
   constructor Comobject (byval value as String )  Export
     Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value), -1, 0, 0)-1
     vt = VT_BSTR
     bstrval = SysAllocStringLen(NULL, wlen)   
     MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,StrPtr(value), -1, V_BSTR(@This), wlen)
   
   End constructor

 
   Constructor Comobject(byval lpszSrc AS LPCOLESTR)  Export
      vt = VT_EMPTY
      bstrval = Cast(BSTR,lpszSrc)
   End Constructor


   'Constructor Comobject(byval bSrc as BOOLEAN)
   '   vt = VT_BOOL
   '   boolVal = bSrc 
   'End Constructor

   Constructor Comobject(byval nSrc AS Integer)  Export
      vt = VT_I4
      lVal = nSrc
   End Constructor
   
   
   Constructor Comobject(byval nSrc AS Byte)  Export
      vt = VT_UI1
      bVal = nSrc
   End Constructor
   
   Constructor Comobject(byval nSrc AS Short)  Export
      vt = VT_I2
      iVal = nSrc
   End Constructor
   
    
   Constructor Comobject(byval nSrc AS Long,  vtSrc As VARTYPE = VT_I4)  Export
       Assert(vtSrc = VT_I4 OR  vtSrc = VT_ERROR)
      vt = vtSrc
      lVal = nSrc
   End Constructor
   
   Constructor Comobject(byval fltSrc AS float)  Export
      vt = VT_R4
      fltVal = fltSrc
   End Constructor
   
 
   
   Constructor Comobject(byval dblSrc AS Double)  Export
      V_VT(@this) = VT_R8
      V_R8(@this) = dblSrc
   End Constructor
   
 
   
   Constructor Comobject(byval cySrc AS CY)  Export
      'vt = VT_CY
      'cyVal.Hi = cySrc.Hi
      'cyVal.Lo = cySrc.Lo
      
      V_VT(@this) = VT_CY
      V_CY(@this) = cySrc
   End Constructor
   
   Constructor Comobject(byval pSrc AS IDispatch Ptr,fAddRef As BOOL)  Export
      vt = VT_DISPATCH
      pdispVal = pSrc
      If (pdispVal <> NULL)  Then     ' Need to AddRef as VariantClear will Release
       if (fAddRef) Then
         #Ifdef __FB_COM_NO_VTBL__
           pdispVal->AddRef()
        #Else
           pdispVal->lpvtbl->Release(pdispVal)
        #EndIf
       EndIf
      EndIf
   End Constructor
   
 
   
   Constructor Comobject(byval pSrc AS IUnknown Ptr,fAddRef As BOOL)  Export
      vt = VT_UNKNOWN
      punkVal = pSrc
      If (punkVal <>    NULL)  Then
       if (fAddRef) Then   
         #Ifdef __FB_COM_NO_VTBL__
           punkVal->AddRef()                 ' Need to AddRef as VariantClear will Release
         #Else
           punkVal->lpvtbl->AddRef(punkVal)
        #EndIf
       EndIf
      endif   
   End Constructor
   
 
   
   Constructor Comobject(ByVal value As SAFEARRAY Ptr)  Export
   Dim vvt As VARTYPE
   SafeArrayGetVartype(value,@vvt)
    vt=vvt Or VT_ARRAY
    parray=value
End Constructor

   Constructor Comobject(ByRef decSrc As Const DECIMAL )    Export
    ' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
      V_DECIMAL(@this) = decSrc
      V_VT(@this) = VT_DECIMAL
End Constructor


   
  ' Assignment Operators
 
    operator Comobject.let(ByRef lvarSrc AS Comobject)  Export
      InternalCopy(Cast(VARIANT Ptr,@lvarSrc))
    End Operator
   
    operator Comobject.let(ByVal varSrc as VARIANT)  Export
      InternalCopy(@varSrc)
   End Operator

    operator Comobject.let(byval bstrSrc AS BSTR)  Export
      InternalClear()
      vt = VT_BSTR
      bstrVal = ..SysAllocString(bstrSrc)
      if (bstrVal = NULL And bstrSrc <>    NULL)  Then
         vt = VT_ERROR
         scode = E_OUTOFMEMORY
      EndIf
    End Operator

 operator Comobject.let(byval lpszSrc AS LPCOLESTR)  Export
      InternalClear()
      vt = VT_BSTR
      bstrVal = SysAllocString(lpszSrc)
      if (bstrVal = NULL And lpszSrc <>    NULL)  Then
         vt = VT_ERROR
         scode = E_OUTOFMEMORY
      EndIf
 End Operator

 operator Comobject.let(byval value as STRING)  Export
    if (vt <> VT_BSTR)  Then
       InternalClear()
       vt = VT_BSTR
    EndIf   
   Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value) , -1, 0, 0)-1
   bstrval = SysAllocStringLen(NULL, wlen)   
   MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,  StrPtr(value) , -1,V_BSTR(@This), wlen)
End Operator


 /'operator Comobject.let(byval bSrc as BOOLEAN)
      if (vt <> VT_BOOL)  Then
         InternalClear()
         vt = VT_BOOL
      EndIf
      boolVal =  bSrc 
 End Operator
'/
operator Comobject.let(byval nSrc AS Integer)  Export
       if (vt <>    VT_I4)  Then
         InternalClear()
         vt = VT_I4
      EndIf
      lVal = nSrc
End Operator

 operator Comobject.let(byval nSrc AS BYTE)  Export
    if (vt <>VT_UI1)  Then
         InternalClear()
         vt = VT_UI1
      EndIf
      bVal = nSrc
 End Operator

 operator Comobject.let(byval nSrc AS Short)  Export
      if (vt <>VT_I2)  Then
         InternalClear()
         vt = VT_I2
      EndIf
      iVal = nSrc
 End Operator

operator Comobject.let(byval nSrc AS Long)  Export
      if (vt <> VT_I4) Then
         InternalClear()
         vt = VT_I4
      EndIf
      lVal = nSrc
   End Operator

 operator Comobject.let(byval fltSrc AS float)  Export
      if (vt <>    VT_R4)  Then
         InternalClear()
         vt = VT_R4
      End If
      fltVal = fltSrc
 End Operator

 operator Comobject.let(byval dblSrc As double)  Export
      if (vt <>VT_R8) Then
         InternalClear()
         vt = VT_R8
      End If
      dblVal = dblSrc
 End Operator

 operator Comobject.let(byval cySrc AS CY)  Export
      if (vt <> VT_CY)Then
         InternalClear()
         vt = VT_CY
      EndIf
      cyVal.Hi = cySrc.Hi
      cyVal.Lo = cySrc.Lo
 End Operator

 operator Comobject.let(byval pSrc AS IDispatch ptr)  Export
      InternalClear()
      vt = VT_DISPATCH
      pdispVal = pSrc
      If (pdispVal <> NULL) Then
         #Ifdef __FB_COM_NO_VTBL__
           pdispVal->AddRef()                ' Need to AddRef as VariantClear will Release
         #Else
           pdispVal->lpvtbl->AddRef(pdispVal)
        #EndIf
      End If   
 End Operator


 operator Comobject.let(byval pSrc AS IUnknown ptr)  Export
      InternalClear()
      vt = VT_UNKNOWN
      punkVal = pSrc
      if (punkVal <>   NULL) Then
         #Ifdef __FB_COM_NO_VTBL__
            punkVal->AddRef()                ' Need to AddRef as VariantClear will Release
         #Else
            punkVal->lpvtbl->AddRef(punkVal)
        #EndIf
      EndIf
      Return   
 End Operator

   Operator Comobject.Let(byval p as SAFEARRAY Ptr)  Export
      InternalClear()
      Dim vvt As VARTYPE
      SafeArrayGetVartype(p,@vvt)
      vt= vvt Or VT_ARRAY
      parray=p
   End Operator
   
   Operator Comobject.Let(ByRef decSrc As Const DECIMAL )  Export
      if (V_VT(@this) <> VT_DECIMAL) Then
        this.Clear()
      End If
       ' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
      V_DECIMAL(@this) = decSrc
      V_VT(@this) = VT_DECIMAL

   End Operator
 
   Function Comobject.Clear() As HRESULT  Export
      return VariantClear(@this)
   End Function
   
   Function Comobject.Copy(pSrc As  VARIANT ptr ) As HRESULT  Export
     Return VariantCopy(@this, pSrc)
   End Function 
   
   Function Comobject.Attach(pSrc As  VARIANT ptr) As HRESULT  Export
      Dim As HRESULT hr = Clear()                ' Clear out the variant
      if (0=FAILED(hr))  Then
         memcpy(@this, pSrc, sizeof(VARIANT))     ' Copy the contents and give control to Comobject
         pSrc->vt = VT_EMPTY
         hr = S_OK
      endif
      return hr
   End Function

   Function Comobject.Detach(pDest As VARIANT Ptr )As HRESULT  Export
      Dim As HRESULT hr = VariantClear(pDest) ' Clear out the variant
      if (0=FAILED(hr)) Then
         memcpy(pDest, @this, sizeof(VARIANT))  ' Copy the contents and remove control from Comobject
         vt = VT_EMPTY
         hr = S_OK
      EndIf
      return hr
   End Function
   
   Function Comobject.Detach() As VARIANT Ptr    Export
      Dim pDest As VARIANT Ptr
      Dim As HRESULT hr   
       memcpy(pDest, @this, sizeof(VARIANT))  ' Copy the contents and remove control from Comobject
      Return pDest
   End Function
   
   Function Comobject.ChangeType(vtNew As VARTYPE ,ByVal pSrc As  VARIANT ptr = NULL) As HRESULT  Export
      Dim As VARIANT Ptr pVar = cast(VARIANT Ptr,pSrc)
      If (pVar = NULL) Then
         pVar = @This                     ' Convert in place if pSrc is NULL
      EndIf   
      ' Do nothing if doing in place convert and vts not different
      return ..VariantChangeType(@this, pVar, 0, vtNew)
   End Function
   
    Function Comobject.InternalClear() As HRESULT
       Dim As HRESULT hr = Clear()
       Assert(SUCCEEDED(hr))
      if (FAILED(hr)) Then
         vt = VT_ERROR
         scode = hr
      EndIf
      return hr
   End Function

   Sub Comobject.InternalCopy(ByVal pSrc as VARIANT Ptr )
   Dim As   HRESULT hr = Copy(pSrc)
      if (FAILED(hr)) Then
         vt = VT_ERROR
         scode = hr
      EndIf
   End Sub

 'Operator Comobject.cast() as BOOLEAN
 '   Return this.boolval
 'End Operator
 
 Operator Comobject.cast() as Integer  Export
    If (V_VT(@this) = VT_INT) Then
      return V_INT(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_INT)
   return V_INT(@vvar)
 End Operator
 
   Operator Comobject.cast()As Byte  Export
      If (V_VT(@this) = VT_UI1) Then
      return V_UI1(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_UI1)
   return V_UI1(@vvar)
   End Operator

   
  Operator Comobject.cast() AS Short  Export
     If (V_VT(@this) = VT_I2) Then
      return V_I2(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I2)
   return V_I2(@vvar)
  End Operator
 
   
  operator Comobject.cast() AS Long  Export
     If (V_VT(@this) = VT_I4) Then
      return V_I4(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I4)
   return V_I4(@vvar)
  End Operator
 
 
 
  operator Comobject.cast() AS float  Export
     If (V_VT(@this) = VT_R4) Then
      return V_R4(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R4)
   return V_R4(@vvar)
  End Operator
 
   
  operator Comobject.cast() AS Double  Export
     If (V_VT(@this) = VT_R8) Then
      return V_R8(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R8)
   return V_R8(@vvar)
  End Operator
 
   
  operator Comobject.cast() AS CY  Export
      if (V_VT(@this) = VT_CY) Then
      return V_CY(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_CY)
   return V_CY(@vvar)
  End Operator
 
 operator Comobject.cast() AS DECIMAL   Export
    if (V_VT(@this) = VT_DECIMAL) Then
      return V_DECIMAL(@this)
   End If
   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DECIMAL)
   return V_DECIMAL(@vvar)
 End Operator

 
 
  Operator Comobject.cast() as String  Export
    Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
   return *Cast(wString Ptr,vvar.bstrval)
 End Operator

 
 
Operator Comobject.cast() as BSTR  Export
    Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
   return  vvar.bstrval
End Operator

 
 
  operator Comobject.cast() AS IDispatch Ptr  Export
     If (V_VT(@this) = VT_DISPATCH) then
      #Ifdef __FB_COM_NO_VTBL__
          V_DISPATCH(@This)->AddRef()
      #Else
          V_DISPATCH(@This)->lpvtbl->AddRef((@This)->pdispval)
      #EndIf   
      return V_DISPATCH(@this)
   End If

   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
    #Ifdef __FB_COM_NO_VTBL__
      V_DISPATCH(@vvar)->AddRef()
   #Else
      V_DISPATCH(@vvar)->lpvtbl->AddRef((@vvar)->pdispval)
   #EndIf   
   return V_DISPATCH(@vvar)
  End Operator
 
 
  operator Comobject.cast() AS IUnknown Ptr  Export
     if (V_VT(@this) = VT_UNKNOWN) then
      #Ifdef __FB_COM_NO_VTBL__
         V_UNKNOWN(@this)->AddRef()
      #Else
         V_UNKNOWN(@This)->lpvtbl->AddRef((@This)->punkval)
      #EndIf     
      return V_UNKNOWN(@this)
   End If

   Dim vvar As variant
    VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_UNKNOWN)
   #Ifdef __FB_COM_NO_VTBL__
      V_UNKNOWN(@vvar)->AddRef()
   #Else
      V_UNKNOWN(@vvar)->lpvtbl->AddRef((@vvar)->punkval)
   #EndIf   
   
   return V_UNKNOWN(@vvar)
  End Operator
 
 
 
 operator Comobject.cast() as SAFEARRAY Ptr  Export
   if (vt And VT_ARRAY)=VT_ARRAY Then 
      Return this.parray
   Else
        Dim vvar As variant
      VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_ARRAY Or (vt Xor VT_ARRAY) )
      Return vvar.parray
   EndIf   
End Operator


Function Comobject.WriteToStream(pStream As IStream Ptr) As HRESULT  Export
 
   Dim As HRESULT hr
   #Ifdef __FB_COM_NO_VTBL__
      hr= pStream->Write(@vt, sizeof(VARTYPE), NULL)
   #Else
      hr= pStream->lpvtbl->Write(pStream,@vt, sizeof(VARTYPE), NULL)
   #EndIf   
   if (FAILED(hr)) Then
      return hr
   EndIf
   Dim As Integer cbWrite = 0
   Select Case (vt)
   
      case VT_UNKNOWN,VT_DISPATCH:
      
         Dim spStream As IPersistStream Ptr
         if (punkVal <>    NULL) Then
            #Ifdef __FB_COM_NO_VTBL__
                hr = punkVal->QueryInterface(@IID_IPersistStream, cast(lpvoid Ptr,@spStream))
            #Else
               hr=punkVal->lpvtbl->QueryInterface(punkVal,@IID_IPersistStream, cast(lpvoid Ptr,@spStream))
            #EndIf
            if (FAILED(hr)) Then
               return hr
            EndIf   
         EndIf
         if (spStream <> NULL) Then
            return OleSaveToStream(spStream, pStream)
         else
            return WriteClassStm(pStream,@CLSID_NULL)
         EndIf
   case VT_UI1,VT_I1:
      cbWrite = sizeof(BYTE)
      
   case VT_I2,VT_UI2,VT_BOOL:
      cbWrite = sizeof(short)
      
   case VT_I4,VT_UI4,VT_R4,VT_INT,VT_UINT, VT_ERROR:
      cbWrite = sizeof(long)
   
   case VT_R8,VT_CY,VT_DATE:
      cbWrite = sizeof(double)
      
   Case Else
      
   End Select
   if (cbWrite <>    0) Then
      #Ifdef __FB_COM_NO_VTBL__
          Return pStream->Write(cast(lpvoid Ptr, @bVal), cbWrite, NULL)
      #Else
          Return pStream->lpvtbl->Write(pStream,Cast(lpvoid Ptr, @bVal), cbWrite, NULL)
      #EndIf
   EndIf
   'bon pour finaliser
   #Ifndef __WIDESTRING_INC__
     Dim As BSTR bstrWrite
   #Else
     Dim As WideString bstrWrite
   #EndIf
   Dim As Comobject varBSTR
   if (vt <> VT_BSTR)Then
 
      hr = VariantChangeType(@varBSTR, @this, VARIANT_NOVALUEPROP, VT_BSTR)
      if (FAILED(hr)) Then
         return hr
      EndIf   
      bstrWrite = varBSTR.bstrVal
   
   else
      bstrWrite = bstrVal
   EndIf
   
   #Ifndef __WIDESTRING_INC__
      Return  BstrWriteToStream(bstrWrite,pStream)
   #Else
      Return bstrWrite.WriteToStream(pStream)
   #EndIf
   
   Return S_OK
End Function

Function Comobject.ReadFromStream(pStream As IStream Ptr ) As  HRESULT  Export
 
   Assert(pStream <>    NULL)
   Dim As HRESULT hr
   hr = VariantClear(@this)
   if (FAILED(hr)) Then
      return hr
   EndIf
   Dim As VARTYPE vtRead
      #Ifdef __FB_COM_NO_VTBL__
         hr = pStream->Read(@vtRead, sizeof(VARTYPE), NULL)
      #Else
         hr= pStream->lpvtbl->Read(pStream,@vtRead, sizeof(VARTYPE), NULL)
      #EndIf
   if (hr = S_FALSE) Then
      hr = E_FAIL
   EndIf
   if (FAILED(hr)) Then
      return hr
   EndIf
   vt = vtRead
   Dim As Integer cbRead = 0
   Select Case (vtRead)
   
   
   case VT_UNKNOWN,VT_DISPATCH:
      
         punkVal = NULL
         hr = OleLoadFromStream(pStream, _
            iif(vtRead = VT_UNKNOWN, @IID_IUnknown , @IID_IDispatch), _
            cast(LPVOID Ptr,@punkVal))
         if (hr = REGDB_E_CLASSNOTREG) Then
            hr = S_OK
         EndIf
         return S_OK
      
   case VT_UI1,VT_I1:
      cbRead = sizeof(BYTE)
      
   Case VT_I2,VT_UI2,VT_BOOL:
      cbRead = sizeof(short)
      
   case VT_I4,VT_UI4,VT_R4,VT_INT,VT_UINT,VT_ERROR:
      cbRead = sizeof(long)
      
   case VT_R8,VT_CY,VT_DATE:
      cbRead = sizeof(double)
      
   Case Else
      
   End Select
   if (cbRead <> 0)Then
       #Ifdef __FB_COM_NO_VTBL__
           hr = pStream->Read(cast(lpvoid,@bVal), cbRead, NULL)
       #Else
          hr= pStream->lpvtbl->Read(pStream,Cast(lpvoid,@bVal), cbRead, NULL)
      #EndIf
      if (hr = S_FALSE) Then
         hr = E_FAIL
      EndIf
      return hr
   EndIf
   Dim As Comobject bstrRead
   Dim tempv As VARIANT
   hr = bstrRead.ReadFromStream(pStream)
   if (FAILED(hr)) Then
      return hr
   EndIf
   vt = VT_BSTR
     bstrRead.Detach(@tempv)
   bstrVal= tempv.bstrVal 
   if (vtRead <> VT_BSTR) Then
      hr = ChangeType(vtRead)
   EndIf
   return hr
End Function

Operator Comobject.+= ( byval rhs as string )   Export
   Dim as VARIANT tmp = any, res = any
   VariantInit( @tmp )
   Var wlen = MultiByteToWideChar(CP_ACP, NULL, StrPtr(rhs), &HFFFFFFFF, 0, 0)-1
   V_VT(@tmp) = VT_BSTR
   V_BSTR(@tmp) = SysAllocStringLen(NULL, wlen)   
   MultiByteToWideChar(CP_ACP, NULL, StrPtr(rhs), &HFFFFFFFF, V_BSTR(@tmp), wlen)
   VarAdd( @This, @tmp, @res )
   VariantClear( @This )
   This = res
   VariantClear( @tmp )
End Operator


Sub Comobject.CreateObject (ByVal ProgID as LPCOLESTR)   Export

 Dim As IDISPATCH Ptr pdisp = NULL
 Dim As IUNKNOWN Ptr  punk  = NULL
 Dim as HRESULT hr
 
     
        oleInitialize(NULL)
   
         
      Dim As  CLSID clsid
      hr=CLSIDFromProgID(ProgID, @clsid)
      If clsid=CLSID_NULL Then hr=CLSIDFromString(ProgID, @clsid)
      If clsid=CLSID_NULL Then goto errorn
 
      hr = CoCreateInstance(@clsid, NULL,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
       
      If  FAILED(hr)  then   goto errorn
       #Ifdef __FB_COM_NO_VTBL__
         hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@pdisp))
       #Else
         hr = punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@pdisp))
       #EndIf
      If  FAILED(hr)  Then goto errorn
 
        
      #Ifdef __FB_COM_NO_VTBL__
         punk->Release()
      #Else
         punk->lpvtbl->Release(punk)
      #EndIf
      This.vt=VT_DISPATCH
      this.pdispval= pdisp
      Return
errorn:
         OleErrorShow(hr,"CreateObject(" & Chr(34) & *Cast(WString Ptr,ProgID) & Chr(34) & ")" )
   #Ifdef __FB_COM_NO_VTBL__
      If (punk)  Then punk->Release() 
      If (pdisp) Then pdisp->Release() 
   #Else
      If (punk)  Then punk->lpvtbl->Release(punk)
      If (pdisp) Then pdisp->lpvtbl->Release(pdisp)
   #EndIf
   
End Sub

Sub Comobject.CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR)  Export
    Dim As COSERVERINFO si
   si.pwszName = Cast(LPWSTR,szMachine)

    CreateObject(szProgId, @IID_IDispatch, _
          IIf( szMachine , CLSCTX_REMOTE_SERVER , CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER), _
          IIf( szMachine , @si , NULL), cast(LPVOID Ptr, @pdispval))
End Sub
Function Comobject.CreateObject (szProgId As LPCOLESTR ,riid As REFIID ,dwClsContext As DWORD , _
                                  mpServerInfo As COSERVERINFO ptr ,ppv as lpvoid Ptr ) As HRESULT  Export
 
   Dim As CLSID clsid
   Dim As HRESULT hr
   Dim As IClassFactory ptr pCf = NULL

   

   if (Len(szProgId)=0 or riid=NULL or  ppv=NULL) Then Return  E_INVALIDARG
   hr = CLSIDFromProgID(szProgId, @clsid)
   If clsid=IID_NULL Then
      hr = CLSIDFromString(szProgId, @clsid)
   EndIf
   If clsid=IID_NULL Then 
      OleErrorShow(hr,"CreateObject(" & Chr(34) & *Cast(WString Ptr,szProgId) & Chr(34) & ")" )
      Return hr
   EndIf
   
   hr = CoGetClassObject(@clsid, dwClsContext, mpServerInfo, @IID_IClassFactory, Cast(lpvoid Ptr, @pCf))
   #Ifdef __FB_COM_NO_VTBL__
      If (SUCCEEDED(hr)) Then hr = pCf->CreateInstance(NULL, riid, ppv)
      if (pCf) Then pCf->Release()
   #Else
      If (SUCCEEDED(hr)) Then hr = pCf->lpVtbl->CreateInstance(pCf, NULL, riid, ppv)
      if (pCf) Then pCf->lpVtbl->Release(pCf)
   #EndIf
   return  hr
End Function

Function Comobject.GetObjectEx(szPathName As LPCOLESTR ,szProgId As LPCOLESTR ,riid As REFIID , _
                                dwClsContext As DWORD ,lpvReserved As LPVOID , ppv As LPVOID Ptr) As HRESULT
 
   Dim As HRESULT hr

   if ((Len(szProgId)=0 and Len(szPathName)=0) Or  riid=NULL Or  ppv=NULL Or lpvReserved<>0) Then Return  E_INVALIDARG
   if Len(szPathName) Then
      if len(szProgId)=0 Then
         hr = CoGetObject(szPathName, NULL, riid, ppv)
      else
         Dim As IPersistFile ptr ppf = NULL
         hr = CreateObject(szProgId, @IID_IPersistFile, dwClsContext, NULL, cast(lpvoid Ptr, @ppf))
            #Ifdef __FB_COM_NO_VTBL__ 
                   If (SUCCEEDED(hr)) Then hr = ppf->Load(szPathName, 0)
                   If (SUCCEEDED(hr)) Then hr = ppf->QueryInterface(riid, ppv)
                    If (ppf) Then ppf->Release()
            #Else
                   If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->Load(ppf, szPathName, 0)
                   If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->QueryInterface(ppf, riid, ppv)
                    If (ppf) Then ppf->lpVtbl->Release(ppf)
            #EndIf 
      EndIf
   
   else
   

      Dim As CLSID clsid
      Dim As IUnknown Ptr pUnk = NULL

      hr = CLSIDFromProgID(szProgId, @clsid)
      If clsid=IID_NULL Then
           hr = CLSIDFromString(szProgId, @clsid)
      EndIf
      If clsid=IID_NULL Then 
          OleErrorShow(hr,"CreateObject(" & Chr(34) & *szProgId & Chr(34) & ")" )
          Return hr
       EndIf
      hr = GetActiveObject(@clsid, NULL, @pUnk)
      #Ifdef __FB_COM_NO_VTBL__ 
            If (SUCCEEDED(hr)) Then hr = pUnk->QueryInterface(riid, ppv)
            If (pUnk) Then pUnk->Release()
      #Else
           If (SUCCEEDED(hr)) Then hr = pUnk->lpVtbl->QueryInterface(pUnk, riid, ppv)
           If (pUnk) Then pUnk->lpVtbl->Release(pUnk)
      #EndIf
   EndIf   

   return  hr 
End Function

 

Sub Comobject.GetObject(szPathName As LPCOLESTR =NULL,szProgId As LPCOLESTR)  Export
    Dim pDisp As IDispatch Ptr 
      GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL,@pDisp) ' curiosly bug with Cast(LPVOID Ptr,@pDisp))
    
    this.vt=VT_DISPATCH
    this.pdispval=pDisp
End Sub

Sub Comobject.GetObject(strName As LPCOLESTR)   
   
      if (strName = NULL) Then
         return 
      End If
 
      

      'Dim As Integer size = lstrlenA(strName) + 1
      Dim As LPOLESTR strNameW =Cast(LPOLESTR,strName) 'Cast(LPOLESTR,Allocate(size * 2))

      'strNameW[0] = Asc("\0")

      'MultiByteToWideChar(CP_ACP, 0, strName, -1, strNameW, size)

      Dim As HRESULT hr = CoGetObject(strNameW, NULL, @IID_IDispatch,  Cast(lpvoid Ptr,@pdispval))

      
   End Sub

Function Comobject.getEnumVariant() As IEnumVARIANT Ptr  Export
  Dim As LPUNKNOWN punkEnum
    Dim As IEnumVARIANT ptr penum = NULL 
    ' Get _NewEnum property. Returns enumerator's IUnknown.
    punkEnum = this.propget("_NewEnum") 
    Dim As HRESULT hr
    #Ifdef __FB_COM_NO_VTBL__ 
       hr= punkEnum->QueryInterface(@IID_IEnumVARIANT, cast(LPVOID Ptr,@penum))
       punkEnum->Release()
       
    #Else
       hr= punkEnum->lpVtbl->QueryInterface(punkEnum,@IID_IEnumVARIANT, cast(LPVOID Ptr,@penum))
        punkEnum->lpVtbl->Release(punkEnum)
    #EndIf   
       
    Return  penum
End Function

Sub Comobject.AttachControl(hwnd As HWND)  Export
    AtlAxAttachControl(Cast(IUnknown Ptr,this.pdispval),hwnd,NULL)
End Sub
Function Comobject.Invoke  Cdecl  (wFlags As WORD ,szName As LPCOLESTR , pszFmt as String="" ,argList As Any Ptr)As Comobject  Export
    Dim vRet As  VARIANT
    'Dim As Any Ptr argList
    'argList= va_first() 
    Dim As ..DISPID dispidm
    Dim As HRESULT hr
    Dim As VARIANTARG ptr pvarg = NULL
    Dim As VARIANTARG ptr pParams = NULL
    variantinit(@vRet)
   
   
   
     if (this.pdispval =  NULL)Then
         OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
        vRet.scode = -1
      return vRet
    End If
    ' Get DISPID of property/method
   #Ifdef __FB_COM_NO_VTBL__ 
      hr = this.pdispval->GetIDsOfNames(@IID_NULL,Cast(LPOLESTR Ptr,@szName), 1, LOCALE_USER_DEFAULT, @dispidm)
   #Else
      hr = this.pdispval->lpvtbl->GetIDsOfNames(this.pdispval,@IID_NULL, Cast(LPOLESTR Ptr,@szName), 1, LOCALE_USER_DEFAULT, @dispidm)
   #EndIf
    if(FAILED(hr))Then
        OleErrorShow(hr,*Cast(WString Ptr,szName))
        vRet.vt = VT_ERROR
        vRet.scode = -1
        Return vRet
    End If           
   Dim As ..DISPPARAMS dispparams
    memset(@dispparams, 0, SizeOf(..DISPPARAMS))

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        dispparams.cArgs=CountArgsInFormat(pszFmt)
    End If
    ' Property puts have a named argument that represents the value that the property is
    ' being assigned.
    Dim As ..DISPID dispidNamed = DISPID_PROPERTYPUT
    if (wFlags And(DISPATCH_PROPERTYPUT Or DISPATCH_PROPERTYPUTREF))Then
         If (dispparams.cArgs =  0)Then
            OleErrorShow(ResultFromScode(E_INVALIDARG),*Cast(WString Ptr,szName))
            vRet.vt = VT_ERROR
            vRet.scode = -1
            Return vRet
         End If   
        dispparams.cNamedArgs = 1
        dispparams.rgdispidNamedArgs = @dispidNamed
    End If

    if (dispparams.cArgs <> 0)Then
        pParams= new VARIANTARG[dispparams.cArgs]  ' allocate memory for all VARIANTARG parameters
        pvarg = new VARIANTARG[dispparams.cArgs]
        if(pvarg = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY),*Cast(WString Ptr,szName))
            vRet.vt = VT_ERROR
            vRet.scode = -1
            Return vRet 
        End If
       
      'memset(pvarg, 0, sizeof(VARIANTARG) * dispparams.cArgs)
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To dispparams.cArgs
             GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte)
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short)
               argList=va_next(argList,short) 
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long)
               argList=va_next(argList,long) 
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float)
               argList=va_next(argList,float) 
            Case VT_DATE:
               pParams[i-1].date = va_arg(argList,DATE_)
               argList=va_next(argList, DATE_)    
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double)
               argList=va_next(argList, double)
               
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY)
               argList=va_next(argList, CY) 
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr))
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY) 
                  pParams[i-1].vt = VT_EMPTY
                  GoTo cleanup 
               End If
                 argList=va_next(argList, OLECHAR Ptr)
                 
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                 
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE)
               argList=va_next(argList,  SCODE)
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,VARIANT_BOOL),-1,0)
               argList=va_next(argList,VARIANT_BOOL)
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr)
               argList=va_next(argList,VARIANTARG Ptr) 
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN)
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN)
           
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr)
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr)
               argList=va_next(argList,short Ptr)
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr)
               argList=va_next(argList,long Ptr)
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr)
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr)
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr)
               argList=va_next(argList,DATE_ Ptr)
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr)
               argList=va_next(argList, CY Ptr)
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr)
               argList=va_next(argList,BSTR Ptr)
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr) 
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr)
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr)
               argList=va_next(argList,SCODE Ptr)
            case VT_BOOL OR VT_BYREF:
               Dim As  VARIANT_BOOL Ptr pbool = va_arg(argList, VARIANT_BOOL Ptr)
               '*pbool = 0
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool)
               argList=va_next(argList,VARIANT_BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF:
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr)
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr)
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr) 
           
            case VT_RECORD :
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr)
                argList=va_next(argList,Any Ptr Ptr) 
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                       pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr )
                      argList=va_next(argList,SAFEARRAY Ptr Ptr)
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY),*Cast(WString Ptr,szName))
                 
            End Select

             
        Next i
       
    End if 'if
   
    ' Initialize return variant, in case caller forgot. Caller can pass NULL if return
    ' value is not expected.
    'if (@vRet)Then
    '    VariantInit(@vRet) 
    'End If
    ' inverser les parametres avant de les passer à dispparams
       For i As Integer= 0  to dispparams.cArgs-1   
            pvarg[i] = pParams[dispparams.cArgs-i-1]
        Next
       
       dispparams.rgvarg = pvarg
    ' make the call
   #Ifdef __FB_COM_NO_VTBL__
        hr = this.pdispval->Invoke(dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL)
    #Else
        hr = this.pdispval->lpvtbl->Invoke(this.pdispval,dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL)
    #EndIf
     OleErrorShow(hr,"pdisp->Invoke in " & *szName)
     
cleanup:
    ' cleanup any arguments that need cleanup

   If(dispparams.cArgs > 0)Then
      for   i As Integer= 0  to dispparams.cArgs-1   
         pParams[dispparams.cArgs-i-1]=pvarg[i] 
      next   
   End If   


    if (dispparams.cArgs <> 0)Then
      For i As Integer= 0  to dispparams.cArgs-1   
          If pvarg[i].vt=VT_BSTR  Then VariantClear(@pvarg[i])
      Next   
    End If
   
   
    delete dispparams.rgvarg
    delete pParams
   
    return vRet   
End function 

Function Comobject.Method Cdecl( MethodName As LPCOLESTR , pszFmt as String="" ,...)As Comobject  Export
    Return Invoke(DISPATCH_METHOD,MethodName,pszFmt,va_first())
End function 

Function Comobject.PropGet Cdecl ( PropName As LPCOLESTR , pszFmt as String="" , ...)As Comobject  Export
   Return Invoke(DISPATCH_PROPERTYGET,PropName,pszFmt,va_first())
End function 
 
Sub  Comobject.PropPut  Cdecl ( szName As LPCOLESTR,pszFmt as String,...)      Export
   Invoke(DISPATCH_PROPERTYPUT,szName,pszFmt,va_first())   
End Sub
Sub  Comobject.PropPutRef  Cdecl ( szName As LPCOLESTR,pszFmt as String,...)   Export
   Invoke(DISPATCH_PROPERTYPUTREF,szName,pszFmt,va_first())
End Sub


'''''''''''''''''    PRIVATE FUNCTIONS '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Private Function Comobject.CountArgsInFormat(pszFmt As String) As UINT 
    return PARSECOUNT(pszFmt,",")
End Function


Private Function  Comobject.GetVarType(psmzFmt As  String ,pvt as VARTYPE Ptr ) As  String 
 
    *pvt = 0
   
    ' Cas Particulier des safearrays
    If InStr(psmzFmt,"%t") Then
         *pvt =VT_ARRAY Or VT_BYREF
         psmzFmt=Right(psmzFmt,1)
        Select Case Trim(psmzFmt)
          Case "a"
            *pvt  OR = VT_UI1            
        case  ("b"):
            *pvt  OR = VT_BOOL
 
        case  ("i"):
            *pvt  OR = VT_I2
     
        case  ("I"):
            *pvt  OR = VT_I4
 
        case  ("r"):
            *pvt  OR = VT_R4
 

        case  ("R"):
            *pvt  OR = VT_R8
           
        case  ("c"):
            *pvt  OR = VT_CY
 
        case  ("s"):
            *pvt  OR = VT_BSTR
 
        case  ("e"):
            *pvt  OR = VT_ERROR
 
        case  ("d"):
            *pvt  OR = VT_DATE 
 
        case  ("v"):
            *pvt  OR = VT_VARIANT
           
         Case  ("U"):
            *pvt  OR = VT_UNKNOWN 
 
       case  ("D"):
            *pvt  Or = VT_DISPATCH
           
      case  ("p"):
            *pvt= VT_RECORD
       Case  (!"\0")
             return ""     ' End of Format string
        Case else:
            return ""
      End Select
    End If
   
   
    ' Cas des parametres byref
   
    if InStr(psmzFmt,"@") Then
         *pvt = VT_BYREF
         If (NULL=Len(psmzFmt))Then
             return ""
         End If       
    End If
   
   
   
    psmzFmt=Right(psmzFmt,1)
   
    Select Case Trim(psmzFmt)
          Case "a"
            *pvt  OR = VT_UI1            
        case  ("b"):
            *pvt  OR = VT_BOOL
 
        case  ("i"):
            *pvt  OR = VT_I2
     
        case  ("I"):
            *pvt  OR = VT_I4
 
        case  ("r"):
            *pvt  OR = VT_R4
 

        case  ("R"):
            *pvt  OR = VT_R8
           
        case  ("c"):
            *pvt  OR = VT_CY
 
        case  ("s"):
            *pvt  OR = VT_BSTR
 
        case  ("e"):
            *pvt  OR = VT_ERROR
 
        case  ("d"):
            *pvt  OR = VT_DATE 
 
        case  ("v"):
            *pvt  OR = VT_VARIANT
           
         Case  ("U"):
            *pvt  OR = VT_UNKNOWN 
 
         Case  ("D"):
            *pvt  Or = VT_DISPATCH
 
        Case  ("p"):
            *pvt = VT_RECORD
        case  (!"\0")
             return ""     ' End of Format string
        Case else:
            return ""
    End Select
 
    return  psmzFmt 
End Function

Private Function Comobject.PARSECOUNT( source As String, delimiter As String=",")As Long
   Dim As Long i,s,c,l
   s=1
   l=1
   Do
      i=Instr(s,source,Any delimiter)
      If i>0 Then
         c+=1
         s=i+l
      End If
   Loop Until i=0
   Function=c+1
End Function

Private Function Comobject.PARSE  (source as string, delimiter as String="|", index as integer)as String
   Dim As Long i,s,c,l
   s=1
   l=Len(delimiter)
   do
      If c=index-1 then
         function=mid(source,s,instr(s,source,delimiter)-s)
         exit function
      end if
      i=instr(s,source,delimiter)
      If i>0 then
         c+=1
         s=i+l
      end if
   loop until i=0
End Function

 
Private Sub Comobject.OleErrorShow ( hr As HRESULT, addit As String="")
 Dim serr As String
 If hr=s_ok Then Exit Sub
   
   Dim As Any Ptr pMsg
   FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,hr, _
                  MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),Cast(LPTSTR,@pMsg),0,NULL)
   Dim As String sCheckError= " : Error(&h" & Hex(hr) & "): "  & *Cast(ZString Ptr,pMsg)
   LocalFree(pMsg)
 
     serr=addit & " " & sCheckError
   MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub





 Operator <>(ByVal V As Comobject,ByVal varSrc as VARIANT) As BOOL  Export
    Return (@v=@varSrc)
   End Operator
   
  Operator  <(ByVal V As Comobject,ByVal varSrc as VARIANT)  As BOOL   Export
    Return VarCmp(@V,@varSrc, LOCALE_USER_DEFAULT, 0)=VARCMP_LT
  End Operator

Operator >(ByVal V As Comobject,ByVal varSrc as VARIANT)  As BOOL   Export
        Return VarCmp(@V,@varSrc, LOCALE_USER_DEFAULT, 0)=VARCMP_GT
End Operator
    
Operator =(ByVal V As Comobject,ByVal varSrc as VARIANT) As BOOL  Export
      if (@V = @varSrc)  Then
         return TRUE
      EndIf
      ' Variants not equal if types don't match
      if (V.vt <>varSrc.vt)  Then
         return FALSE
      EndIf
      ' Check type specific values
      Select Case (V.vt)
      
         case VT_EMPTY,VT_NULL:
            return TRUE

         case VT_BOOL:
            return (V.boolVal = varSrc.boolVal)

         case VT_UI1:
            return (V.bVal = varSrc.bVal)

         case VT_I2:
            return V.iVal = varSrc.iVal

         case VT_I4:
            return V.lVal = varSrc.lVal

         case VT_R4:
            return V.fltVal = varSrc.fltVal

         case VT_R8:
            return V.dblVal = varSrc.dblVal

         case VT_BSTR:
            return (SysStringByteLen(V.bstrVal) = SysStringByteLen(varSrc.bstrVal)) And _
                   (memcmp(V.bstrVal, varSrc.bstrVal, SysStringByteLen(V.bstrVal)) = 0)

         case VT_ERROR:
            return V.scode = varSrc.scode

         case VT_DISPATCH:
            return V.pdispVal = varSrc.pdispVal

         case VT_UNKNOWN:
            return V.punkVal = varSrc.punkVal

         Case Else
             Assert(false)
            ' fall through
      End Select

      return FALSE
   End Operator
   
#EndIf   


don't worry about #Ifdef __FB_COM_NO_VTBL__ you don't have to define __FB_COM_NO_VTBL__
this code can be also compiled successfully with FB1.07
coderJeff
Site Admin
Posts: 3118
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: FreeBASIC 1.07.0 Release Discussion

Postby coderJeff » Sep 04, 2019 1:43

aloberoger wrote:in my tests I found that some old dll run successfully see
...
can we have a theory for the type of dll that can be executed successfully


The type of DLL that can be executed successfully (I would think always), is the one that is compiled in same version of fbc (and target) as the main program.

Anyway, here is more explanation of why you see it sometimes work, sometimes not:

One change for libraries going from fbc 1.05 to fbc 1.06 is the way that procedures are named in libraries (name mangling, or name decoration). Specifically, before fbc 1.06, fbc's integer and long types did not map well to C's long and int types. They were reversed. Nobody really noticed because both are 32-bit in 32-bit fbc. Later, this added other complications to 64-bit. For plain "c" procedures it really didn't matter on 32-bit. Having the mapping reversed really causes problems when start using classes and namespaces, so it was fixed in fbc 1.06

One change for libraries going from fbc 1.06 to fbc 1.07 is the way procedures are named in libraries for overloaded operator procedures. Name decoration was wrong, and causes problems for linking with other kinds of libraries, so was fixed in fbc 1.07.
aloberoger
Posts: 480
Joined: Jan 13, 2009 19:23

Re: FreeBASIC 1.07.0 Release Discussion

Postby aloberoger » Sep 04, 2019 18:33

OK
TeeEmCee
Posts: 261
Joined: Jul 22, 2006 0:54
Location: Auckland

Re: FreeBASIC 1.07.0 Release Discussion

Postby TeeEmCee » Sep 05, 2019 4:38

The release of FB 1.07 took me by surprise, but is welcome.
Is there any kind of schedule for future releases? Or any set of changes that you want to finish before releasing 1.08?
coderJeff
Site Admin
Posts: 3118
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: FreeBASIC 1.07.0 Release Discussion

Postby coderJeff » Sep 08, 2019 12:33

TeeEmCee wrote:Is there any kind of schedule for future releases?

No schedule. I feel like making a schedule will take all the fun out of this. My goal is about 1 or 2 releases a year, if possible. Maybe January-ish?

Or any set of changes that you want to finish before releasing 1.08?

There is "a lot" on the go, but number of developers are limited. So can't really say what exactly will be in the next release. Top items on my list:
- a newer "offical" version of gcc. This may involve a number of changes/updates required due dependencies on binutils, gcc, and supporting libraries, i.e. fbc's headers. So we'll see.
- finish the u|z|wstring stuff that was started earlier this year. Fix related bugs
- fix array() related bugs
- add the "thiscall" calling convention. This would help for linking to c++ libraries. This is relatively straight forward for 32-bit gcc backend, which I have worked on and tested. Challenging to add to 32-bit gas backend. It doesn't matter in 64-bit.
- and add the static operators to UDT's. This completes a feature I'd like to see in fbc, and also allows better ABI compatibility with g++ libs.
- add the u|int128 name mangling. fbc won't support natively, but could generate proper name mangling for linking to g++ libs
- fix more bugs, I'd really like to reduce the number of open issues on sf.net
- otherwise, I try to listen to what community is interested in, and let users help determine goals. So, often, my own goals drop down the list.
paul doe
Posts: 956
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: FreeBASIC 1.07.0 Release Discussion

Postby paul doe » Sep 09, 2019 20:50

Way to go, Jeff! I hadn't got around to test 1.07 yet. Will do soon enough, though =D
coderJeff wrote:...
@dodicat, I see your regulate() function in many of your listings and seems to work well. Like it should be built in to an extension SCREENSYNC somehow as a gfxlib feature for software based timing.

Or part of the 'FbRTLib'? As fb_regulateFps() or something along those lines? This way, we can start to improve FreeBasic with commonly used community produced code =D
coderJeff
Site Admin
Posts: 3118
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: FreeBASIC 1.07 Release Discussion

Postby coderJeff » Sep 10, 2019 0:51

Thanks paul. Well, if you haven't tried it yet, there's another one coming soon. :)
coderJeff
Site Admin
Posts: 3118
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: FreeBASIC 1.07 Release Discussion

Postby coderJeff » Sep 10, 2019 1:18

I've been working on next 1.07.1 release.

Here's why:

The 1.07.0 release was a logical necessary step. Because of some compiler changes that are coming up, it felt necessary to create a fairly stable save point and release it before making those changes.

This also provides an opportunity for a branch point because coincident and recent on the forums, are topics discussing alternate toolchains, like new mingw toolchain (Equation tool chain), with srvaldez and deltarho[1859] testing other gcc versions, and building tools to test multiple versions of fbc/gcc. There are also some old discussions about the age of current default gcc compiler version used for releases.

Here's what:

So I started on a 1.07.1 release. It is almost the exact same source code as 1.07.0. The main difference is in the build scripts and packaging so we can release several packages that are each intended to be used with different versions of gcc. I hope it goes well.

The first pull request was at Build release packages for mingw-w64 gcc 5.2.0, gcc 7.1.0, gcc 7.3.0, & gcc 8.1.0 #175 and is now merged in to the fbc-1.07 branch on github.

I've done only the mingw-w64 packages so far:
- mingw-w64 gcc-8.1.0 (rev0) binutils 2.30
- mingw-w64 gcc-7.3.0 (rev0) binutils 2.30
- mingw-w64 gcc-7.1.0 (rev2) binutils 2.28
- mingw-w64 gcc-5.2.0 (rev0) binutils 2.25
- default is gcc-5.2

It takes about 7 hours to build everything. They have all passed the main test, which is that the release can rebuild fbc compiler and pass the testsuite.

I missed one option for mingw-w64, which was staring me right in the face the whole time:
- mingw-w64 gcc-7.1.0 (rev0) binutils 2.27

The significance of the gcc-7.1.0 (rev0) target, is 1) that's the one I'm using on my development pc, and 2) it's the same binutils version as the Equation tool chain. So while it's older, it may give some flexibility in exploring the Equation tool chain.

The purpose for the fbc-1.07 branch is for alternate release packages only. I have no intention of fixing bugs on multiple branches. Development and bug fixing is on fbc/master branch only.

Return to “Community Discussion”

Who is online

Users browsing this forum: No registered users and 1 guest