Index: /trunk/Include/Classes/ActiveBasic/Strings/SPrintF.ab =================================================================== --- /trunk/Include/Classes/ActiveBasic/Strings/SPrintF.ab (revision 335) +++ /trunk/Include/Classes/ActiveBasic/Strings/SPrintF.ab (revision 335) @@ -0,0 +1,232 @@ +'Classes/ActiveBasic/Strings/SPrintF.ab + +Namespace ActiveBasic +Namespace Strings + +Namespace Detail + +/*! +@brief 浮動小数点数を文字列化する低水準な関数。符号、指数、仮数に分けて出力。 +@author Egtra +@date 2007/09/18 +@param[in] x 文字列化する浮動小数点数 +@param[out] e 指数 +@param[out] sign 符号 +@return 仮数 +仮数は1の位から下へ17桁で、小数点を含まない。そのため、誤差を無視すればVal(仮数) * 10 ^ (e - 17) = Abs(x)が成り立つ。 + +xに無限大、無限小、非数を渡した場合の動作は未定義。 +*/ +Function FloatToChars(x As Double, ByRef e As Long, ByRef sign As Boolean) As String + Imports System + + '0を弾く + If x = 0 Then + If GetQWord(VarPtr(x) As *QWord) And &h8000000000000000 Then + sign = True + Else + sign = False + End If + + e = 0 + FloatToChars = "00000000000000000" + Exit Function + End If + + '符号の判断（同時に符号を取り除く） + If x < 0 Then + sign = True + x = -x + Else + + sign = False + End If + + '1e16 <= x < 1e17へ正規化 + '(元のx) = (正規化後のx) ^ (d - 17)である。 + Dim d = Math.Floor(Math.Log10(x)) As Long + If d < 16 Then + x *= ipow(10, +17 - d) + ElseIf d > 16 Then + x /= ipow(10, -17 + d) + End If + + '補正 + While x < 1e16 + x *= 10 + d-- + Wend + While x >= 1e17 + x /= 10 + d++ + Wend + + d-- + e = d + + FloatToChars = Str$(x As QWord) +End Function + +/*! +@brief 書式化関数群で使用するフラグ。 +@author Egtra +@date 2007/09/18 +*/ +Const Enum FormatFlags + '! 何も指定がない。 + None = &h0 + '! 符号、+。符号付変換[diAaEeFfGg]のとき、正の値でも符号を付ける。 + Sign = &h1 + /*! 空白、空白文字。 + 符号付変換[diAaEeFfGg]のとき、正の値ならば符号分の空白を開ける。Signが立っているときには無視される。 + */ + Blank = &h2 + /*! ゼロ、0。 + [diouXxAaEeFfGg]で、フィールドの空きを0で埋める。leftが立っているときには無視される。 + */ + Zero = &h4 + '! 左揃え、-。フィールド内で左揃えにする。 + Left = &h8 + /*! 代替表記、#。 + +
  • [AaEeFfGg]では、精度0でも小数点を付ける。 +
  • [Gg]では、それに加え、小数部末尾の0の省略を行わないようにする。 + + */ + Alt = &h10 + '! 大文字。使用するアルファベットを大文字にする。[aefgx]を[AEFGX]化する。 + Cap = &h20 +End Enum + +/*! +@brief 浮動小数点数をprintfの%e, %E相当の変換で文字列化する関数。 +@author Egtra +@date 2007/09/18 +@param[in] x 文字列化する浮動小数点数値。 +@param[in] d 精度。小数点以下の桁数。DWORD_MAXのとき、指定なしとして既定値6となる。 +@param[in] field フィールド幅。 +@param[in] flags 書式フラグ。 +@return xの文字列表現 + +@todo 末尾桁四捨五入 +*/ +Function FormatFloatE(x As Double, d As DWord, field As DWord, flags As FormatFlags) As String + Dim sb = New System.Text.StringBuilder + With sb + If d = DWORD_MAX Then + d = 6 + End If + + Dim e As Long, sign As Boolean + Dim s = FloatToChars(x, e, sign) + + If sign Then + .Append("-") + Else + If flags And Sign Then + .Append("+") + ElseIf flags And Blank Then + .Append(" ") + End If + End If + + .Append(s[0]) + + If (flags And Alt) Or d > 0 Then + .Append(".") + Dim outputLen = s.Length - 1 + If outputLen >= d Then + .Append(s, 1, d) + Else 'sで用意された桁が指定された精度より少ないとき + .Append(s, 1, outputLen) + .Append(&h30 As StrChar, d - outputLen) '足りない桁は0埋め + End If + End If + + If flags And Cap Then + .Append("E") + Else + .Append("e") + End If + + Dim buf[1023] As TCHAR + wsprintf(buf, "%03d", e)' "%+03d", e) wsprintfは+フラグが使えない！ + Dim ts = New String(buf, 3) + .Append(ts) + '.Append(FormatLongD(e, 3, 0, Sign) + + If .Length < field Then + Dim embeddedSize = .Length - field + If flags And Left Then + .Append(&h20, embeddedSize) + Else + Dim insPos As Long + If flags And Blank Then + insPos++ + End If + .Insert(insPos, String$(embeddedSize, " ")) + End If + End If + End With + FormatFloatE = sb.ToString() +End Function + +'! DWordの最大値4294967295の文字数 - 1。FormatIntegerU内で使用。 +Const MaxSize = 9 + +/*! +@brief 符号無し整数をprintfの%u相当の変換で文字列化する関数。 +@author Egtra +@date 2007/09/18 +@param[in] x 文字列化する整数値。 +@param[in] d 精度、最小限表示される桁数。DWORD_MAXのとき、指定なしとして、既定値1となる。 +@param[in] field フィールド幅。 +@param[in] flags 書式フラグ。 +@return xの文字列表現 +*/ +Function FormatIntegerU(x As DWord, d As DWord, field As DWord, flags As FormatFlags) As String + 'zero, left + + '左揃えのときまたは精度が指定されているとき、ゼロフラグは無視される。 + If (flags And Left) Or (d <> DWORD_MAX) Then + flags And= Not Zero + End If + + If d = DWORD_MAX Then + d = 1 + End If + + Dim sb = New System.Text.StringBuilder + With sb + Dim buf[MaxSize] As StrChar + Dim i = MaxSize + While x <> 0 + buf[i] = (x As Int64 Mod 10 + &h30) As StrChar 'Int64への型変換は#117対策 + x \= 10 + i-- + Wend + + Dim len = (MaxSize - i) As Long + If len < d Then + .Append(&h30 As StrChar, d - len) + End If + + .Append(buf, i + 1, len) + + If field > len Then + Dim embeddedSize = field - len + If flags And Left Then + .Append(&h20, embeddedSize) + Else + .Insert(0, String$(embeddedSize, " ")) + End If + End If + End With + FormatIntegerU = sb.ToString() +End Function + +End Namespace 'Detail + +End Namespace 'Strings +End Namespace 'ActiveBasic Index: /trunk/Include/Classes/ActiveBasic/Windows/CriticalSection.ab =================================================================== --- /trunk/Include/Classes/ActiveBasic/Windows/CriticalSection.ab (revision 334) +++ /trunk/Include/Classes/ActiveBasic/Windows/CriticalSection.ab (revision 335) @@ -53,8 +53,8 @@ /*Override*/ Sub Dispose() -' Dim p = ActiveBasic.Windows.Detail.InterlockedExchangeAnyPointer(pcs, 0) - Dim p = InterlockedExchangePointer(pcs As VoidPtr, 0) As *CRITICAL_SECTION - If p <> 0 Then - LeaveCriticalSection(ByVal p) +' Dim pcsOld = ActiveBasic.Windows.Detail.InterlockedExchangeAnyPointer(pcs, 0) + Dim pcsOld = InterlockedExchangePointer(pcs As VoidPtr, 0) As *CRITICAL_SECTION + If pcsOld <> 0 Then + LeaveCriticalSection(ByVal pcsOld) End If End Sub Index: /trunk/Include/Classes/ActiveBasic/index.ab =================================================================== --- /trunk/Include/Classes/ActiveBasic/index.ab (revision 334) +++ /trunk/Include/Classes/ActiveBasic/index.ab (revision 335) @@ -1,1 +1,2 @@ #require "./Core/index.ab" +#require "./Windows/index.ab" Index: /trunk/Include/Classes/System/Diagnostics/TraceListener.ab =================================================================== --- /trunk/Include/Classes/System/Diagnostics/TraceListener.ab (revision 334) +++ /trunk/Include/Classes/System/Diagnostics/TraceListener.ab (revision 335) @@ -141,5 +141,5 @@ ' デバッグビューへ出力 Dim tempStr = GetIndentString() + message - OutputDebugString( tempStr ) + OutputDebugString( ToTCStr(tempStr) ) ' デバッグログへ書き込む Index: /trunk/Include/Classes/System/Drawing/Color.ab =================================================================== --- /trunk/Include/Classes/System/Drawing/Color.ab (revision 334) +++ /trunk/Include/Classes/System/Drawing/Color.ab (revision 335) @@ -4,5 +4,5 @@ #define __SYSTEM_DRAWING_COLOR_AB__ -#include +'#include #include @@ -76,9 +76,9 @@ ToCOLORREF = RGB(R, G, B) End Function - +/* Function ToArgb() As ARGB - Return argb - End Function - + ToArgb = argb + End Function +*/ Static Function FromArgb(argb As ARGB) As Color Return New Color(argb) Index: /trunk/Include/Classes/System/Drawing/Rectangle.ab =================================================================== --- /trunk/Include/Classes/System/Drawing/Rectangle.ab (revision 334) +++ /trunk/Include/Classes/System/Drawing/Rectangle.ab (revision 335) @@ -4,5 +4,5 @@ #define __SYSTEM_DRAWING_RECTANGLE_AB__ -#require +'#require #require #require Index: /trunk/Include/Classes/System/Drawing/RectangleF.ab =================================================================== --- /trunk/Include/Classes/System/Drawing/RectangleF.ab (revision 334) +++ /trunk/Include/Classes/System/Drawing/RectangleF.ab (revision 335) @@ -4,5 +4,5 @@ #define __SYSTEM_DRAWING_RECTANGLEF_AB__ -#include +'#include #include #include Index: /trunk/Include/Classes/System/Drawing/Size.ab =================================================================== --- /trunk/Include/Classes/System/Drawing/Size.ab (revision 334) +++ /trunk/Include/Classes/System/Drawing/Size.ab (revision 335) @@ -4,5 +4,5 @@ #define __SYSTEM_DRAWING_SIZE_AB__ -#include +'#include #include Index: /trunk/Include/com/bstring.ab =================================================================== --- /trunk/Include/com/bstring.ab (revision 334) +++ /trunk/Include/com/bstring.ab (revision 335) @@ -1,6 +1,6 @@ ' com/bstring.ab -#require -#require +'#require +'#require Namespace ActiveBasic @@ -19,5 +19,5 @@ Sub BString(s As BString) - Init(s.bs, s.Length) + BString.Copy(This.bs, s.bs) End Sub @@ -50,15 +50,15 @@ Sub Assign(bstr As BString) Clear() - Init(bstr, bstr.Length) + BString.Copy(This.bs, bstr.bs) End Sub Sub Assign(s As LPCOLESTR) Clear() - Init(s, lstrlenW(s)) + s = SysAllocString(s) End Sub Sub AssignFromBStr(bstr As BSTR) Clear() - String.Copy(bs, bstr) + BString.Copy(bs, bstr) End Sub Index: /trunk/Include/com/currency.ab =================================================================== --- /trunk/Include/com/currency.ab (revision 334) +++ /trunk/Include/com/currency.ab (revision 335) @@ -28,8 +28,9 @@ End Sub */ +/* Const Function Operator +() As Currency Return New Currency(This) End Function - +*/ Const Function Operator -() As Currency Dim ret = New Currency @@ -58,10 +59,13 @@ Const Function Operator /(y As Variant) As Double Dim vx = New Variant(This) - Dim ret= vx / y + Dim ret = vx / y Return ret.ValR4 End Function Const Function Operator /(y As Currency) As Double - Return This / New Varinat(y) + Dim vx = New Variant(This) + Dim vy = New Variant(y) + Dim ret = vx / vy + Return ret.ValR4 End Function @@ -79,13 +83,13 @@ Static Function Compare(x As Currency, y As Currency) As HRESULT - Return VarCyCmp(x, y) + Return VarCyCmp(x.cy, y.cy) End Function Static Function Compare(x As Currency, y As Double) As HRESULT - Return VarCyCmpR8(x, y) + Return VarCyCmpR8(x.cy, y) End Function Static Function Compare(x As Double, y As Currency) As HRESULT - Dim ret = VarCyCmpR8(y, x) + Dim ret = VarCyCmpR8(y.cy, x) Select Case ret Case VARCMP_LT @@ -140,20 +144,20 @@ Const Function Operator <=(y As Currency) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_LT Or result = VARCMP_EQ + Return c = VARCMP_LT Or c = VARCMP_EQ End Function Const Function Operator <=(y As Double) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_LT Or result = VARCMP_EQ + Return c = VARCMP_LT Or c = VARCMP_EQ End Function Const Function Operator >=(y As Currency) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_GT Or result = VARCMP_EQ + Return c = VARCMP_GT Or c = VARCMP_EQ End Function Const Function Operator >=(y As Double) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_GT Or result = VARCMP_EQ + Return c = VARCMP_GT Or c = VARCMP_EQ End Function Index: /trunk/Include/com/decimal.ab =================================================================== --- /trunk/Include/com/decimal.ab (revision 334) +++ /trunk/Include/com/decimal.ab (revision 335) @@ -1,5 +1,5 @@ ' com/decimal.ab -#require +'#require #require #require @@ -14,5 +14,6 @@ Sub Decimal(d As Decimal) - dec = d +' dec = d なぜかコンパイルできない + memcpy(VarPtr(dec), VarPtr(d), Len(dec)) End Sub @@ -56,5 +57,5 @@ VarDecFromR8(x, dec) End Sub - +/* Const Function Operator() As Variant Return New Variant(This) @@ -195,8 +196,9 @@ End Function */ +/* Const Function Operator +() As Decimal Return New Decimal(dec) End Function - +*/ Const Function Operator -() As Decimal Dim ret = New Decimal @@ -211,16 +213,4 @@ End Function - Const Function Operator *(y As Long) As Decimal - Dim ret = New Decimal - VarDecMulI4(This.dec, y, ret.dec) - Return ret - End Function - - Const Function Operator *(y As Int64) As Decimal - Dim ret = New Decimal - VarDecMulI8(This.dec, y, ret.dec) - Return ret - End Function - Const Function Operator /(y As Decimal) As Decimal Dim ret = New Decimal @@ -242,13 +232,13 @@ Static Function Compare(x As Decimal, y As Decimal) As HRESULT - Return VarDecCmp(x, y) + Return VarDecCmp(x.dec, y.dec) End Function Static Function Compare(x As Decimal, y As Double) As HRESULT - Return VarDecCmpR8(x, y) + Return VarDecCmpR8(x.dec, y) End Function Static Function Compare(x As Double, y As Decimal) As HRESULT - Dim ret = VarDecCmpR8(y, x) + Dim ret = VarDecCmpR8(y.dec, x) Select Case ret Case VARCMP_LT @@ -303,20 +293,20 @@ Const Function Operator <=(y As Decimal) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_LT Or result = VARCMP_EQ + Return c = VARCMP_LT Or c = VARCMP_EQ End Function Const Function Operator <=(y As Double) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_LT Or result = VARCMP_EQ + Return c = VARCMP_LT Or c = VARCMP_EQ End Function Const Function Operator >=(y As Decimal) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_GT Or result = VARCMP_EQ + Return c = VARCMP_GT Or c = VARCMP_EQ End Function Const Function Operator >=(y As Double) As Boolean Dim c = Compare(This, y) - Return result = VARCMP_GT Or result = VARCMP_EQ + Return c = VARCMP_GT Or c = VARCMP_EQ End Function Index: /trunk/Include/com/variant.ab =================================================================== --- /trunk/Include/com/variant.ab (revision 334) +++ /trunk/Include/com/variant.ab (revision 335) @@ -4,6 +4,6 @@ #define _COM_VARIANT_AB -#require -#require +'#require +'#require #require @@ -127,5 +127,5 @@ v.vt = VT_EMPTY End Sub - +/* Sub Operator =(y As Variant) Assign(y.v) @@ -135,5 +135,5 @@ Assign(y) End Sub - +*/ Sub Assign(from As Variant) Assign(from.v) @@ -202,5 +202,5 @@ Const Function Operator \(y As Variant) As Variant Dim ret = New Variant - VarIDiv(This.v, y.v, ret.v) + VarIdiv(This.v, y.v, ret.v) Return ret End Function @@ -340,5 +340,5 @@ Const Function Operator <=(y As Variant) As Boolean Dim c = Compare(This, y) - If result = VARCMP_LT Or result = VARCMP_EQ Then + If c = VARCMP_LT Or c = VARCMP_EQ Then Return True Else @@ -349,5 +349,5 @@ Const Function Operator >=(y As Variant) As Boolean Dim c = Compare(This, y) - If result = VARCMP_GT Or result = VARCMP_EQ Then + If c = VARCMP_GT Or c = VARCMP_EQ Then Return True Else @@ -391,5 +391,5 @@ Const Function ValUI1() As Byte Dim r = ChangeType(VT_UI1) - Return GetByte(VarPtr(r.val)) + Return GetByte(VarPtr(r.v.val)) End Function @@ -402,5 +402,5 @@ Const Function ValUI2() As Word Dim r = ChangeType(VT_UI2) - Return GetWord(VarPtr(r.val)) + Return GetWord(VarPtr(r.v.val)) End Function @@ -413,5 +413,5 @@ Const Function ValUI4() As DWord Dim r = ChangeType(VT_UI4) - Return GetDWord(VarPtr(r.val)) + Return GetDWord(VarPtr(r.v.val)) End Function @@ -424,5 +424,5 @@ Const Function ValUI8() As QWord Dim r = ChangeType(VT_UI8) - Return GetQWord(VarPtr(r.val)) + Return GetQWord(VarPtr(r.v.val)) End Function @@ -501,5 +501,5 @@ Const Function ValBool() As VARIANT_BOOL Dim r = ChangeType(VT_BOOL) - Return GetWord(VarPtr(r.val)) + Return GetWord(VarPtr(r.v.val)) End Function @@ -557,5 +557,5 @@ Sub ValUnknown(x As *IUnknown) Clear() - SetPointer(VarPtr(v.val), x.Copy()) + SetPointer(VarPtr(v.val), x) x->AddRef() v.vt = VT_UNKNOWN Index: /trunk/Include/com/vbobject.ab =================================================================== --- /trunk/Include/com/vbobject.ab (revision 334) +++ /trunk/Include/com/vbobject.ab (revision 335) @@ -165,5 +165,5 @@ End Function - Sub Prop(ByRef arg As Variant) + Sub Prop(arg As Variant) Prop(ByVal arg.PtrToVariant) End Sub @@ -173,6 +173,6 @@ End Sub - Sub PropRef(ByRef arg As Variant) - PropRef(arg.PtrToVariant) + Sub PropRef(arg As Variant) + PropRef(ByVal arg.PtrToVariant) End Sub @@ -297,9 +297,9 @@ Function CreateObject(className As PCWSTR) As VBObject - Return New VBObject(className) + Return New VBObject(className, 0, CLSCTX_ALL) End Function Function CreateObject(className As String) As VBObject - Return New VBObject(ToWCStr(className)) + Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL) End Function /* Index: /trunk/TestCase/SimpleTestCase/SPrintFTest.ab =================================================================== --- /trunk/TestCase/SimpleTestCase/SPrintFTest.ab (revision 335) +++ /trunk/TestCase/SimpleTestCase/SPrintFTest.ab (revision 335) @@ -0,0 +1,44 @@ +'-------------------------------------------------------------------- +' Test case of SPrintF Function and etc... +'-------------------------------------------------------------------- + +#require + +Imports ActiveBasic.Strings +Imports ActiveBasic.Strings.Detail + +Namespace SPrintFTest + +Sub TestMain() + Dim s = Nothing As String, e As Long, sign As Boolean + + s = FloatToChars(1., e, sign) + UnitTest("FloatToChars(1)", s = "10000000000000000" And e = 0 And sign = False) + + s = FloatToChars(-93.75e-3, e, sign) + UnitTest("FloatToChars(-93.75e-3)", s = "93750000000000000" And e = 1 - 3 And sign = True) + + s = FloatToChars(.0, e, sign) + UnitTest("FloatToChars(0)", s = "00000000000000000" And e = 0 And sign = False) + + s = FormatFloatE(9.876543e021, 6, 0, None) + UnitTest("FormatFloatE(9876543e021)", s = "9.876543e021") + + s = FormatFloatE(7.81250000E-003, 8, 0, Cap) + UnitTest("FormatFloatE(7.81250000E-003)", s = "7.81250000E-003") + /* + 上は、現在s = 7.81250000E-03となり失敗する。 + FormatIntegerDを作成していないことが要因。 + */ + + s = FormatIntegerU(777, 0, 0, None) + UnitTest("FormatIntegerU(777)", s = "777") + + s = FormatIntegerU(513, 0, 5, None) + UnitTest("FormatIntegerU(513, Field size = 5)", s = " 513") + +End Sub + +End Namespace 'SPrintFTest + +SPrintFTest.TestMain() Index: /trunk/TestCase/SimpleTestCase/SimpleTestCase.idx =================================================================== --- /trunk/TestCase/SimpleTestCase/SimpleTestCase.idx (revision 334) +++ /trunk/TestCase/SimpleTestCase/SimpleTestCase.idx (revision 335) @@ -22,2 +22,8 @@ #include "BlittableTest.ab" _ClearNamespaceImported +#include "SPrintFTest.ab" +_ClearNamespaceImported + +'リソースファイル +#include "resource.ab" +#resource "SimpleTestCase.rc" Index: /trunk/TestCase/SimpleTestCase/SimpleTestCase.pj =================================================================== --- /trunk/TestCase/SimpleTestCase/SimpleTestCase.pj (revision 334) +++ /trunk/TestCase/SimpleTestCase/SimpleTestCase.pj (revision 335) @@ -23,5 +23,5 @@ #DEBUG_EXE_PATH= -#RESOURCE=0 +#RESOURCE=SimpleTestCase.rc #SOURCE @@ -36,2 +36,3 @@ StringBuilderTest.ab BlittableTest.ab +SPrintFTest.ab