Discussion of FreeBASIC 1.07.x releases, issues, comments, remarks, etc.
Full release announcement posts
- fbc-1.07.3 at Version 1.07.3 released (Full Release).
- fbc-1.07.3 Win64 at Version 1.07.3 released (Win64 Only).
- fbc-1.07.2 at Version 1.07.2 released.
- fbc-1.07.1 at Version 1.07.1 released.
- fbc-1.07.0 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 :-(
FreeBASIC 1.07 Release Discussion
Re: FreeBASIC 1.07.0 Release Discussion
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.
link: changelog.txt
I took the liberty of changing your topic title.
Re: FreeBASIC 1.07.0 Release Discussion
Thanks for the new version!
Re: FreeBASIC 1.07.0 Release Discussion
Thanks coderJeff and all people involved for FreeBASIC 1.07!
Code: Select all
| | | | | |
| |_| |__ __ _ _ __ | | ___ _ ___ _ _
| __| '_ \ / _` | '_ \| |/ / | | |/ _ \| | | |
| |_| | | | (_| | | | | <| |_| | (_) | |_| |
\__|_| |_|\__,_|_| |_|_|\_\\__, |\___/ \__,_|
__/ |
|___/
Re: FreeBASIC 1.07.0 Release Discussion
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 Re: FreeBASIC 1.07.0 Release Discussion
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.
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: 4305
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: FreeBASIC 1.07.0 Release Discussion
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>
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: 507
- Joined: Jan 13, 2009 19:23
Re: FreeBASIC 1.07.0 Release Discussion
OKCoderjeff 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.
Indeed you have been clear.
in my tests I found that some old dll run successfully see http://s000.tinyupload.com/?file_id=565 ... 1317791492
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 this code can be also compiled successfully with FB1.07
Re: FreeBASIC 1.07.0 Release Discussion
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.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
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: 507
- Joined: Jan 13, 2009 19:23
Re: FreeBASIC 1.07.0 Release Discussion
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?
Is there any kind of schedule for future releases? Or any set of changes that you want to finish before releasing 1.08?
Re: FreeBASIC 1.07.0 Release Discussion
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?TeeEmCee wrote:Is there any kind of schedule for future releases?
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:Or any set of changes that you want to finish before releasing 1.08?
- 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.
Re: FreeBASIC 1.07.0 Release Discussion
Way to go, Jeff! I hadn't got around to test 1.07 yet. Will do soon enough, though =D
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 =DcoderJeff 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.
Re: FreeBASIC 1.07 Release Discussion
Thanks paul. Well, if you haven't tried it yet, there's another one coming soon. :)
Re: FreeBASIC 1.07 Release Discussion
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.
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.