source: trunk/Include/basic/function.sbp@ 394

'function.sbp


#ifndef _INC_FUNCTION
#define _INC_FUNCTION


Const _System_PI = 3.14159265358979323846264
Const _System_LOG2 = 0.6931471805599453094172321214581765680755
Const _System_SQRT2 = 1.41421356237309504880168872421
Const _System_Log_N = 7 As Long


#require <Classes/System/Math.ab>
#require <Classes/System/DateTime.ab>
#require <Classes/System/Text/StringBuilder.ab>
#require <Classes/ActiveBasic/Math/Math.ab>
#require <Classes/ActiveBasic/Strings/Strings.ab>


'------------- サポート関数の定義 -------------

Function ldexp(x As Double, n As Long) As Double
    If x = 0 Then
        ldexp = 0
        Exit Function
    End If
    Dim pSrc = VarPtr(x) As *QWord
    Dim pDest = VarPtr(ldexp) As *QWord
    n += (pSrc[0] >> 52) As DWord And &h7FF
    pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
End Function

Function frexp(x As Double, ByRef n As Long) As Double
    If x = 0 Then
        n = 0
        frexp = 0
        Exit Function
    End If

    Dim pSrc = VarPtr(x) As *QWord
    Dim pDest = VarPtr(frexp) As *QWord
    n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
    pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
End Function

Function frexp(x As Single, ByRef n As Long) As Single
    If x = 0 Then
        n = 0
        frexp = 0
        Exit Function
    End If

    Dim pSrc As *DWord, pDest As *DWord
    pSrc = VarPtr(x) As *DWord
    pDest = VarPtr(frexp) As *DWord
    n = ((pSrc[0] >> 23) And &hFF) - 126
    pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
End Function

Function ipow(x As Double, n As Long) As Double
    Dim abs_n As Long
    Dim r = 1 As Double

    abs_n=Abs(n) As Long
    While abs_n<>0
        If abs_n and 1 Then r *= x
        x = x * x
        abs_n >>= 1 ' abs_n \= 2
    Wend

    If n>=0 Then
        ipow=r
    Else
        ipow=1/r
    End If
End Function

Function pow(x As Double, y As Double) As Double
'   If -LONG_MAX<=y and y<=LONG_MAX and y=CDbl(Int(y)) Then
    If y = (y As Long) Then
        pow = ipow(x, y As Long)
    ElseIf x>0 Then
        pow = Exp(y * Log(x))
        Exit Function
    ElseIf x<>0 or y<=0 Then
        pow = ActiveBasic.Math.Detail.GetNaN()
    Else
        pow = 0
    End If
End Function

Const RAND_MAX = &H7FFFFFFF
Dim _System_RndNext = 1 As DWord

Function rand() As Long
    _System_RndNext = _System_RndNext * 1103515245 + 12345
    rand = (_System_RndNext >> 1) As Long
End Function

Sub srand(dwSeek As DWord)
    _System_RndNext = dwSeek
End Sub


'------------- ここからBasic標準関数の定義 -------------

'------------------
' データ型変換関数
'------------------

Function CDbl(number As Double) As Double
    CDbl=number
End Function

Function _CUDbl(number As QWord) As Double
    _CUDbl=number As Double
End Function

Function CDWord(num As Double) As DWord
    CDWord=num As DWord
End Function

Function CInt(number As Double) As Long
    CInt=number As Long
End Function

Function CSng(number As Double) As Single
    CSng=number As Single
End Function

#ifdef _WIN64
Function Fix(number As Double) As Long
    Fix=number As Long
End Function
#else
'Fix関数はコンパイラに組み込まれている
'Function Fix(number As Double) As Long
#endif

Function Int(number As Double) As Long
    Int = Fix(number)
    If number < 0 Then
        If number < Fix(number) Then Int--
    End If
End Function


'-------------------------------------
' ポインタ関数（コンパイラに組み込み）
'-------------------------------------

'Function GetDouble(p As DWord) As Double
'Function GetSingle(p As DWord) As Single
'Function GetDWord(p As DWord) As DWord
'Function GetWord(p As DWord) As Word
'Function GetByte(p As DWord) As Byte
'Sub SetDouble(p As DWord, dblData As Double)
'Sub SetSingle(p As DWord, fltData As Single)
'Sub SetDWord(p As DWord, dwData As DWord)
'Sub SetWord(p As DWord, wData As Word)
'Sub SetByte(p As DWord, byteData As Byte)


'----------
' 算術関数
'----------

Function Abs(number As Double) As Double
    'Abs = System.Math.Abs(number)
    If number < 0 then
        Abs = -number
    Else
        Abs = number
    End If
End Function

Function Abs(number As Int64) As Int64
    If number < 0 then
        Abs = -number
    Else
        Abs = number
    End If
End Function

Function Abs(number As Long) As Long
    If number < 0 then
        Abs = -number
    Else
        Abs = number
    End If
End Function

Function Exp(x As Double) As Double
    Exp = System.Math.Exp(x)
End Function

Function Log(x As Double) As Double
    Log = System.Math.Log(x)
End Function

Function Sgn(number As Double) As Long
    Sgn = System.Math.Sign(number)
End Function

Function Sqr(number As Double) As Double
    Sqr = System.Math.Sqrt(number)
End Function

Function Atn(number As Double) As Double
    Atn = System.Math.Atan(number)
End Function

Function Atn2(y As Double, x As Double) As Double
    Atn2 = System.Math.Atan2(y, x)
End Function

Function Sin(number As Double) As Double
    Sin = System.Math.Sin(number)
End Function

Function Cos(number As Double) As Double
    Cos = System.Math.Cos(number)
End Function

Function Tan(number As Double) As Double
    Tan = System.Math.Tan(number)
End Function

Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
Function Rnd() As Double
    Rnd = RAND_UNIT * rand()
End Function

Const HIDWORD(qw) = (((qw As QWord) >> 32) And &HFFFFFFFF) As DWord
Const LODWORD(qw) = ((qw As QWord) And &HFFFFFFFF) As DWord

Const MAKEDWORD(l, h) = (((l As DWord) And &HFFFF) Or (((h As DWord) And &HFFFF) << 16)) As DWord
Const MAKEQWORD(l, h) = (((l As QWord) And &HFFFFFFFF) Or (((h As QWord) And &HFFFFFFFF) << 32)) As QWord

'------------
' 文字列関数
'------------

Function Asc(buf As String) As StrChar
    Asc = buf[0]
End Function

Function Chr$(code As StrChar) As String
    Chr$ = New String(code, 1)
End Function

#ifndef __STRING_IS_NOT_UNICODE
Function AscW(s As String) As UCSCHAR
    If String.IsNullOrEmpty(s) Then
        AscW = 0
        'ArgumentNullExceptionに変えるかも
    Else
        If _System_IsHighSurrogate(s[0]) Then
            '有効なサロゲートペアになっていない場合には、
            '例外を投げるようにしたほうがよいかもしれない。
            If s.Length > 1 Then
                If _System_IsLowSurrogate(s[0]) Then
                    AscW = ((s[0] And &h3FF) As DWord << 10) Or (s[1] And &h3FF)
                    Exit Function
                End If
            End If
        Else
            AscW = s[0]
        End If
    End If
End Function

Function ChrW(c As UCSCHAR) As String
    If c <= &hFFFF Then
        Return New String(c As StrChar, 1)
    ElseIf c <= &h10FFFF Then
        Dim t[1] As WCHAR
        t[0] = (&hD800 Or (c >> 10)) As WCHAR
        t[1] = (&hDC00 Or (c And &h3FF)) As WCHAR
        Return New String(t, 2)
    Else
        Throw New System.ArgumentOutOfRangeException("ChrW: c is invalid Unicode code point.", "c")
    End If
End Function
#endif

Function Date$() As String
    Dim date = System.DateTime.Now
    Dim buf = New System.Text.StringBuilder(10)

    'year
    buf.Append(date.Year)

    'month
    If date.Month < 10 Then
        buf.Append("/0")
    Else
        buf.Append("/")
    End If
    buf.Append(date.Month)

    'day
    If date.Day < 10 Then
        buf.Append("/0")
    Else
        buf.Append("/")
    End If
    buf.Append(date.Day)

    Date$ = buf.ToString
End Function

Function Hex$(x As DWord) As String
    Imports ActiveBasic.Strings.Detail
    Hex$ = FormatIntegerX(x, 1, 0, None)
End Function

Function Hex$(x As QWord) As String
    Imports ActiveBasic.Strings.Detail
    Hex$ = FormatIntegerLX(x, 1, 0, None)
End Function

Function InStr(StartPos As Long, buf1 As String, buf2 As String) As Long
    Dim i As Long, i2 As Long, i3 As Long

    Dim len1 = buf1.Length
    Dim len2 = buf2.Length

    If len2=0 Then
        InStr=StartPos
        Exit Function
    End If

    StartPos--
    If StartPos<0 Then
        'error
        InStr=0
        Exit Function
    End If

    i=StartPos:InStr=0
    While i<=len1-len2
        i2=i:i3=0
        Do
            If i3=len2 Then
                InStr=i+1
                Exit Do
            End If
            If buf1[i2]<>buf2[i3] Then Exit Do

            i2++
            i3++
        Loop
        If InStr Then Exit While
        i++
    Wend
End Function

Function Left$(s As String, length As Long) As String
    Left$ = s.Substring(0, System.Math.Min(s.Length, length))
End Function

Function Mid$(s As String, startPos As Long) As String
    startPos--
    Mid$ = s.Substring(startPos)
End Function

Function Mid$(s As String, startPos As Long, readLength = 0 As Long) As String
    startPos--
    Dim length = s.Length
    Mid$ = s.Substring(System.Math.Min(startPos, length), System.Math.Min(readLength, length - startPos))
End Function

Function Oct$(n As QWord) As String
    Imports ActiveBasic.Strings.Detail
    Oct$ = FormatIntegerLO(n, 1, 0, None)
End Function

Function Oct$(n As DWord) As String
    Imports ActiveBasic.Strings.Detail
    Oct$ = FormatIntegerO(n, 1, 0, None)
End Function

Function Right$(s As String, length As Long) As String
    Right$ = s.Substring(System.Math.Max(0, s.Length - length), s.Length)
End Function

Function Space$(length As Long) As String
    Return New String(&h20 As StrChar, length)
End Function

Sub _ecvt_support(buf As *StrChar, count As Long, size As Long)
    Dim i As Long
    If buf[count] = 9 Then
        buf[count] = 0
        If count = 0 Then
            For i = size To 1 Step -1
                buf[i] = buf[i-1]
            Next
            buf[0] = 1
        Else
            _ecvt_support(buf, count-1, size)
        End If
    Else
        buf[count]++
    End If
End Sub

Sub _ecvt(buffer As *StrChar, value As Double, count As Long, ByRef dec As Long, ByRef sign As Boolean)
    Dim i As Long, i2 As Long

    '値が0の場合
    If value = 0 Then
        ActiveBasic.Strings.ChrFill(buffer, count As SIZE_T, &h30 As StrChar)
        buffer[count] = 0
        dec = 0
        sign = 0
        Exit Function
    End If

    '符号の判断（同時に符号を取り除く）
    If value < 0 Then
        sign = True
        value = -value
    Else
        sign = False
    End If

    '正規化
    dec = 1
    While value < 0.999999999999999 'value<1
        value *= 10
        dec--
    Wend
    While 9.99999999999999 <= value '10<=value
        value /= 10
        dec++
    Wend

    For i = 0 To count - 1
        buffer[i] = Int(value) As StrChar
        value = (value-CDbl(Int(value))) * 10
    Next

    i--
    If value >= 5 Then
        '切り上げ処理
        _ecvt_support(buffer, i, count)
    End If

    For i = 0 To count - 1
        buffer[i] += &H30
    Next
    buffer[i] = 0
End Sub

Function Str$(dbl As Double) As String
    Imports ActiveBasic.Math
    Imports ActiveBasic.Strings
    If IsNaN(dbl) Then
        Return "NaN"
    ElseIf IsInf(dbl) Then
        If dbl > 0 Then
            Return "Infinity"
        Else
            Return "-Infinity"
        End If
    End If
    Dim dec As Long, sign As Boolean
    Dim buffer[32] As StrChar, temp[15] As StrChar
    Dim i = 0 As Long

    '浮動小数点を文字列に変換
    _ecvt(temp, dbl, 15, dec, sign)

    '符号の取り付け
    If sign Then
        buffer[i] = Asc("-")
        i++
    End If

    If dec > 15 Or dec < -3 Then
        '指数表示
        buffer[i] = temp[0]
        i++
        buffer[i] = Asc(".")
        i++
        ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)
        i += 14
        buffer[i] = 0
        Return MakeStr(buffer) + SPrintf("e%+03d", New System.Int32(dec - 1))
    End If

    '整数部
    Dim i2 = dec
    Dim i3 = 0
    If i2>0 Then
        While i2>0
            buffer[i]=temp[i3]
            i++
            i3++
            i2--
        Wend
        buffer[i]=Asc(".")
        i++
    Else
        buffer[i]=&H30
        i++
        buffer[i]=Asc(".")
        i++

        i2=dec
        While i2<0
            buffer[i]=&H30
            i++
            i2++
        Wend
    End If

    '小数部
    While i3<15
        buffer[i]=temp[i3]
        i++
        i3++
    Wend

    While buffer[i-1]=&H30
        i--
    Wend
    If buffer[i-1]=Asc(".") Then i--

    buffer[i]=0
    Return MakeStr(buffer)
End Function

Function Str$(x As Int64) As String
    Imports ActiveBasic.Strings.Detail
    Return FormatIntegerEx(TraitsIntegerD[1], x As QWord, 1, 0, None)
End Function

Function Str$(x As QWord) As String
    Imports ActiveBasic.Strings.Detail
    Return FormatIntegerEx(TraitsIntegerU[1], x, 1, 0, None)
End Function

Function Str$(x As Long) As String
    Imports ActiveBasic.Strings.Detail
    Return FormatIntegerEx(TraitsIntegerD[0], x, 1, 0, None)
End Function

Function Str$(x As DWord) As String
    Imports ActiveBasic.Strings.Detail
    Return FormatIntegerEx(TraitsIntegerU[0], x, 1, 0, None)
End Function

Function Str$(x As Word) As String
    Return Str$(x As DWord)
End Function

Function Str$(x As Integer) As String
    Return Str$(x As Long)
End Function

Function Str$(x As Byte) As String
    Return Str$(x As DWord)
End Function

Function Str$(x As SByte) As String
    Return Str$(x As Long)
End Function

Function Str$(x As Single) As String
    Return Str$(x As Double)
End Function

Function Str$(b As Boolean) As String
    If b Then
        Return "True"
    Else
        Return "False"
    End If
End Function

Function String$(n As Long, s As StrChar) As String
    Return New String(s, n)
End Function
        
#ifdef _AB4_COMPATIBILITY_STRING$_
Function String$(n As Long, s As String) As String
    If n < 0 Then
        'Throw ArgumentOutOfRangeException
    End If

    Dim buf = New System.Text.StringBuilder(s.Length * n)
    Dim i As Long
    For i = 0 To n
        buf.Append(s)
    Next
End Function
#else
Function String$(n As Long, s As String) As String
    If String.IsNullOrEmpty(s) Then
        Return New String(0 As StrChar, n)
    Else
        Return New String(s[0], n)
    End If
End Function
#endif

Function Time$() As String
    Dim time = System.DateTime.Now

    Dim buf = New System.Text.StringBuilder(8)

    'hour
    If time.Hour < 10 Then
        buf.Append("0")
    End If
    buf.Append(time.Hour)

    'minute
    If time.Minute < 10 Then
        buf.Append(":0")
    Else
        buf.Append(":")
    End If
    buf.Append(time.Minute)

    'second
    If time.Second < 10 Then
        buf.Append(":0")
    Else
        buf.Append(":")
    End If
    buf.Append(time.Second)
    Time$ = buf.ToString
End Function

Function Val(buf As *StrChar) As Double
    Dim i As Long, i2 As Long, i3 As Long, i4 As Long
    Dim temporary As String
    Dim TempPtr As *StrChar
    Dim dbl As Double
    Dim i64data As Int64

    Val=0

    While buf[0]=Asc(" ") or buf[0]=Asc(Ex"\t")
        buf = VarPtr(buf[1])
    Wend

    If buf[0]=Asc("&") Then
        temporary = New String( buf )
        temporary = temporary.ToUpper()
        TempPtr = StrPtr(temporary)
        If TempPtr(1)=Asc("O") Then
            '8進数
            i=2
            While 1
                '数字以外の文字の場合は抜け出す
                i3=TempPtr[i]-&H30
                If Not (0<=i3 And i3<=7) Then Exit While

                TempPtr[i]=i3 As StrChar
                i++
            Wend
            i--

            i64data=1
            While i>=2
                Val += ( i64data * TempPtr[i] ) As Double

                i64data *= &O10
                i--
            Wend
        ElseIf TempPtr(1)=Asc("H") Then
            '16進数
            i=2
            While 1
                '数字以外の文字の場合は抜け出す
                i3=TempPtr[i]-&H30
                If Not(0<=i3 and i3<=9) Then
                    i3=TempPtr[i]-&H41+10
                    If Not(&HA<=i3 and i3<=&HF) Then Exit While
                End If

                TempPtr[i]=i3 As StrChar
                i++
            Wend
            i--

            i64data=1
            While i>=2
                Val += (i64data*TempPtr[i]) As Double

                i64data *= &H10
                i--
            Wend
        End If
    Else
        '10進数
#ifdef __STRING_IS_NOT_UNICODE
        sscanf(buf,"%lf",VarPtr(Val))
#else
        swscanf(buf,ToWCStr("%lf"),VarPtr(Val))
#endif
    End If
End Function


'--------------
' ファイル関数
'--------------

Function Eof(FileNum As Long) As Long
    Dim dwCurrent As DWord, dwEnd As DWord

    FileNum--

    dwCurrent=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
    dwEnd=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_END)
    SetFilePointer(_System_hFile(FileNum),dwCurrent,NULL,FILE_BEGIN)

    If dwCurrent>=dwEnd Then
        Eof=-1
    Else
        Eof=0
    End If
End Function

Function Lof(FileNum As Long) As Long
    Lof = GetFileSize(_System_hFile(FileNum-1), 0)
End Function

Function Loc(FileNum As Long) As Long
    FileNum--

    Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
    Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
    SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)

    Loc = NowPos - BeginPos
End Function


'------------------
' メモリ関連の関数
'------------------

Function malloc(stSize As SIZE_T) As VoidPtr
    Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
End Function

Function calloc(stSize As SIZE_T) As VoidPtr
    Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
End Function

Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
    If lpMem = 0 Then
        Return malloc(stSize)
    Else
        Return _System_pGC->__realloc(lpMem,stSize)
    End If
End Function

Sub free(lpMem As VoidPtr)
    _System_pGC->__free(lpMem)
End Sub

Function _System_malloc(stSize As SIZE_T) As VoidPtr
    Return HeapAlloc(_System_hProcessHeap,0,stSize)
End Function

Function _System_calloc(stSize As SIZE_T) As VoidPtr
    Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)
End Function

Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
    If lpMem = 0 Then
        Return HeapAlloc(_System_hProcessHeap, 0, stSize)
    Else
        Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
    End If
End Function

Sub _System_free(lpMem As VoidPtr)
    HeapFree(_System_hProcessHeap,0,lpMem)
End Sub


'--------
' その他
'--------

Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
    Dim i As Long, i2 As Long, i3 As Long, length As Long
    Dim buffer[MAX_PATH] As SByte

    '":\"をチェック
    If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub

    'ドライブ名をコピー
    If drive Then
        drive[0]=path[0]
        drive[1]=path[1]
        drive[2]=0
    End If

    'ディレクトリ名をコピー
    i=2
    i2=0
    Do
        If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
            If dir Then
                dir[i2]=path[i]
                dir[i2+1]=path[i+1]
            End If

            i += 2
            i2 += 2
            Continue
        End If

        If path[i]=0 Then Exit Do

        If path[i]=&H5C Then '"\"記号であるかどうか
            i3=i2+1
        End If

        If dir Then dir[i2]=path[i]

        i++
        i2++
    Loop
    If dir Then dir[i3]=0
    i3 += i-i2

    'ファイル名をコピー
    i=i3
    i2=0
    i3=-1
    Do
'#ifdef UNICODE
'       If _System_IsSurrogatePair(path[i], path[i + 1]) Then
'#else
        If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
'#endif
            If fname Then
                fname[i2]=path[i]
                fname[i2+1]=path[i+1]
            End If

            i += 2
            i2 += 2
            Continue
        End If

        If path[i]=0 Then Exit Do

        If path[i]=&H2E Then    '.'記号であるかどうか
            i3=i2
        End If

        If fname Then fname[i2]=path[i]

        i++
        i2++
    Loop
    If i3=-1 Then i3=i2
    If fname Then fname[i3]=0
    i3 += i-i2

    '拡張子名をコピー
    If ext Then
        If i3 Then
            lstrcpy(ext,path+i3)
        End If
        else ext[0]=0
    End If
End Sub

Function GetBasicColor(ColorCode As Long) As Long
    Select Case ColorCode
        Case 0
            GetBasicColor=RGB(0,0,0)
        Case 1
            GetBasicColor=RGB(0,0,255)
        Case 2
            GetBasicColor=RGB(255,0,0)
        Case 3
            GetBasicColor=RGB(255,0,255)
        Case 4
            GetBasicColor=RGB(0,255,0)
        Case 5
            GetBasicColor=RGB(0,255,255)
        Case 6
            GetBasicColor=RGB(255,255,0)
        Case 7
            GetBasicColor=RGB(255,255,255)
    End Select
End Function

Function _System_BSwap(x As Word) As Word
    Dim src = VarPtr(x) As *Byte
    Dim dst = VarPtr(_System_BSwap) As *Byte
    dst[0] = src[1]
    dst[1] = src[0]
End Function

Function _System_BSwap(x As DWord) As DWord
    Dim src = VarPtr(x) As *Byte
    Dim dst = VarPtr(_System_BSwap) As *Byte
    dst[0] = src[3]
    dst[1] = src[2]
    dst[2] = src[1]
    dst[3] = src[0]
End Function

Function _System_BSwap(x As QWord) As QWord
    Dim src = VarPtr(x) As *Byte
    Dim dst = VarPtr(_System_BSwap) As *Byte
    dst[0] = src[7]
    dst[1] = src[6]
    dst[2] = src[5]
    dst[3] = src[4]
    dst[4] = src[3]
    dst[5] = src[2]
    dst[6] = src[1]
    dst[7] = src[0]
End Function

Function _System_HashFromUInt(x As QWord) As Long
    Return (HIDWORD(x) Xor LODWORD(x)) As Long
End Function

Function _System_HashFromUInt(x As DWord) As Long
    Return x As Long
End Function

Function _System_HashFromPtr(p As VoidPtr) As Long
    Return _System_HashFromUInt(p As ULONG_PTR)
End Function

/*!
@brief  ObjPtrの逆。ABオブジェクトを指すポインタをObject型へ変換。
@author Egtra
@date   2007/08/24
@param[in]  p   COMインタフェースを指すポインタ
@return Object参照型
*/
Function _System_PtrObj(p As VoidPtr) As Object
    SetPointer(VarPtr(_System_PtrObj), p)
End Function

/*!
@brief  IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
@author Egtra
@date   2007/09/24
@param[in]  p   COMインタフェースを指すポインタ
@return IUnknown参照型
*/
Function _System_PtrUnknown(p As VoidPtr) As IUnknown
    SetPointer(VarPtr(_System_PtrUnknown), p)
End Function

'--------
' 文字列関数その2
'--------
Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
    If _System_IsHighSurrogate(wcHigh) Then
        If _System_IsLowSurrogate(wcLow) Then
            Return True
        End If
    End If
    Return False
End Function

Function _System_IsHighSurrogate(c As WCHAR) As Boolean
    Return &hD800 <= c And c < &hDC00
End Function

Function _System_IsLowSurrogate(c As WCHAR) As Boolean
    Return &hDC00 <= c And c < &hE000 
End Function

Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
    Return _System_IsSurrogatePair(lead, trail)
End Function

Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
    Return IsDBCSLeadByte(lead) <> FALSE
End Function

Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
    Dim hash = 0 As DWord
    Dim i As Long
    For i = 0 To ELM(n)
        hash = ((hash << 16) + p[i]) Mod &h7fffffff
    Next
    _System_GetHashFromWordArray = hash As Long
End Function

#endif '_INC_FUNCTION